diff --git a/CMakeLists.txt b/CMakeLists.txt
index d5bd3362b..9a2e44281 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -24,8 +24,8 @@ project(${PROJECT_NAME})
enable_language(C Fortran CXX)
set(VERSION_MAJOR "24")
-set(VERSION_MINOR "4")
-set(VERSION_BugFix "5")
+set(VERSION_MINOR "10")
+set(VERSION_BugFix "3")
set(PROJECT_VERSION ${VERSION_MAJOR}.${VERSION_MINOR}.${VERSION_BugFix})
@@ -314,6 +314,8 @@ include(${PROJECT_SOURCE_DIR}/cmake/addPLPLOT.cmake)
include(${PROJECT_SOURCE_DIR}/cmake/addFFTW.cmake)
include(${PROJECT_SOURCE_DIR}/cmake/addGTKFortran.cmake)
include(${PROJECT_SOURCE_DIR}/cmake/addLua.cmake)
+include(${PROJECT_SOURCE_DIR}/cmake/addGmsh.cmake)
+include(${PROJECT_SOURCE_DIR}/cmake/addHDF5.cmake)
# Add source files
include(src/modules/CMakeLists.txt)
diff --git a/cmake/Config.cmake.in b/cmake/Config.cmake.in
index 3758fb80e..73153f1db 100644
--- a/cmake/Config.cmake.in
+++ b/cmake/Config.cmake.in
@@ -1,75 +1,70 @@
@PACKAGE_INIT@
-LIST(
- APPEND
- ExternalLibs
- Sparsekit
- toml-f
-)
+list(APPEND ExternalLibs Sparsekit toml-f)
-IF( @USE_LAPACK95@ )
- LIST(APPEND
- ExternalLibs
- LAPACK95
- )
-ENDIF()
+if(@USE_LAPACK95@)
+ list(APPEND ExternalLibs LAPACK95)
+endif()
-IF( @USE_ARPACK@ )
- LIST(APPEND
- ExternalLibs
- arpackng
- )
-ENDIF()
+if(@USE_ARPACK@)
+ list(APPEND ExternalLibs arpackng)
+endif()
-IF( @USE_RAYLIB@ )
- LIST(APPEND
- ExternalLibs
- raylib
- )
-ENDIF()
+if(@USE_RAYLIB@)
+ list(APPEND ExternalLibs raylib)
+endif()
-FOREACH(LIB ${ExternalLibs})
- FIND_PACKAGE(${LIB} REQUIRED)
-ENDFOREACH()
+foreach(LIB ${ExternalLibs})
+ find_package(${LIB} REQUIRED)
+endforeach()
-IF( @USE_OPENMP@ )
- IF(APPLE)
- IF(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES "AppleClang")
- SET(OpenMP_C "${CMAKE_C_COMPILER}" CACHE STRING "" FORCE)
- SET(OpenMP_C_FLAGS
- "-fopenmp=libomp -Wno-unused-command-line-argument"
- CACHE STRING
- ""
- FORCE
- )
- SET(OpenMP_C_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE)
- SET(OpenMP_libomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE)
- SET(OpenMP_libgomp_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE)
- SET(OpenMP_libiomp5_LIBRARY ${OpenMP_C_LIB_NAMES} CACHE STRING "" FORCE)
+if(@USE_GMSH_SDK@)
+ find_library(GMSH_LIBRARIES NAMES gmsh gmsh.4.13.0 gmsh.4.13 REQUIRED)
+endif()
- SET(OpenMP_CXX "${CMAKE_CXX_COMPILER}" CACHE STRING "" FORCE)
- SET(
- OpenMP_CXX_FLAGS
- "-fopenmp=libomp -Wno-unused-command-line-argument"
- CACHE STRING
- ""
- FORCE
- )
+find_package(HDF5 REQUIRED COMPONENTS Fortran HL)
- SET(OpenMP_CXX_LIB_NAMES "libomp" "libgomp" "libiomp5" CACHE STRING "" FORCE)
- ENDIF()
- ENDIF()
+if(@USE_OPENMP@)
+ if(APPLE)
+ if(CMAKE_C_COMPILER_ID MATCHES "Clang" OR CMAKE_C_COMPILER_ID MATCHES
+ "AppleClang")
+ set(OpenMP_C
+ "${CMAKE_C_COMPILER}"
+ CACHE STRING "" FORCE)
+ set(OpenMP_C_FLAGS
+ "-fopenmp=libomp -Wno-unused-command-line-argument"
+ CACHE STRING "" FORCE)
+ set(OpenMP_C_LIB_NAMES
+ "libomp" "libgomp" "libiomp5"
+ CACHE STRING "" FORCE)
+ set(OpenMP_libomp_LIBRARY
+ ${OpenMP_C_LIB_NAMES}
+ CACHE STRING "" FORCE)
+ set(OpenMP_libgomp_LIBRARY
+ ${OpenMP_C_LIB_NAMES}
+ CACHE STRING "" FORCE)
+ set(OpenMP_libiomp5_LIBRARY
+ ${OpenMP_C_LIB_NAMES}
+ CACHE STRING "" FORCE)
- FIND_PACKAGE(OpenMP REQUIRED)
-ENDIF()
+ set(OpenMP_CXX
+ "${CMAKE_CXX_COMPILER}"
+ CACHE STRING "" FORCE)
+ set(OpenMP_CXX_FLAGS
+ "-fopenmp=libomp -Wno-unused-command-line-argument"
+ CACHE STRING "" FORCE)
+ set(OpenMP_CXX_LIB_NAMES
+ "libomp" "libgomp" "libiomp5"
+ CACHE STRING "" FORCE)
+ endif()
+ endif()
-set_and_check(
- "@PROJECT_NAME@_INCLUDE_DIR" "@PACKAGE_INSTALL_INCLUDEDIR@")
+ find_package(OpenMP REQUIRED)
+endif()
-include(
- "${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake")
+set_and_check("@PROJECT_NAME@_INCLUDE_DIR" "@PACKAGE_INSTALL_INCLUDEDIR@")
-check_required_components(
- "@PROJECT_NAME@"
- )
+include("${CMAKE_CURRENT_LIST_DIR}/@TARGETS_EXPORT_NAME@.cmake")
+
+check_required_components("@PROJECT_NAME@")
diff --git a/cmake/addGmsh.cmake b/cmake/addGmsh.cmake
new file mode 100644
index 000000000..cda7ea718
--- /dev/null
+++ b/cmake/addGmsh.cmake
@@ -0,0 +1,32 @@
+# 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
+
+option(USE_GMSH_SDK OFF)
+if(USE_GMSH_SDK)
+
+ message(STATUS "USING GMSH SDK")
+ list(APPEND TARGET_COMPILE_DEF "-DUSE_GMSH_SDK")
+
+ find_library(GMSH_LIBRARIES NAMES gmsh gmsh.4.13.0 gmsh.4.13 REQUIRED)
+
+ target_link_libraries(${PROJECT_NAME} PUBLIC ${GMSH_LIBRARIES})
+ message(STATUS "GMSH_LIBRARIES : ${GMSH_LIBRARIES}")
+
+else()
+
+ message(STATUS "NOT USING GMSH SDK")
+
+endif()
diff --git a/cmake/addHDF5.cmake b/cmake/addHDF5.cmake
new file mode 100644
index 000000000..1c04bec08
--- /dev/null
+++ b/cmake/addHDF5.cmake
@@ -0,0 +1,33 @@
+# 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(HDF5_NO_FIND_PACKAGE_CONFIG_FILE true CACHE BOOL "Set true to skip trying
+# to find hdf5-config.cmake" FORCE)
+find_package(HDF5 REQUIRED COMPONENTS Fortran HL)
+if(HDF5_VERSION VERSION_LESS 1.8.7)
+ message(WARNING "HDF5 VERSION SHOULD BE >= 1.8.7")
+endif()
+if(HDF5_FOUND)
+ message(STATUS "HDF5 FOUND: ")
+ list(APPEND TARGET_COMPILE_DEF "-DUSE_HDF5")
+ list(APPEND TARGET_COMPILE_DEF "${HDF5_Fortran_DEFINITIONS}")
+ message(STATUS "HDF5 fortran lib :: ${HDF5_Fortran_LIBRARIES}")
+else()
+ message(ERROR "HDF5 NOT FOUND")
+endif()
+target_link_libraries(${PROJECT_NAME} PUBLIC ${HDF5_Fortran_LIBRARIES})
+target_include_directories(${PROJECT_NAME} PUBLIC ${HDF5_Fortran_INCLUDE_DIRS})
diff --git a/cmake/addLIS.cmake b/cmake/addLIS.cmake
index 9ad7dd5f9..fe6693c0d 100644
--- a/cmake/addLIS.cmake
+++ b/cmake/addLIS.cmake
@@ -14,7 +14,6 @@
#
# You should have received a copy of the GNU General Public License along with
# this program. If not, see
-#
option(USE_LIS OFF)
if(USE_LIS)
diff --git a/cmake/addToml.cmake b/cmake/addToml.cmake
index 295bf1efd..76fc2eb77 100644
--- a/cmake/addToml.cmake
+++ b/cmake/addToml.cmake
@@ -18,7 +18,7 @@
find_package(toml-f REQUIRED)
-if(Sparsekit_FOUND)
+if(toml-f_FOUND)
message(STATUS "[INFO] :: FOUND toml-f")
target_link_libraries(${PROJECT_NAME} PUBLIC toml-f::toml-f)
diff --git a/src/modules/BLAS95/src/F95_BLAS.F90 b/src/modules/BLAS95/src/F95_BLAS.F90
index 9f5b8bb01..419ac54f6 100644
--- a/src/modules/BLAS95/src/F95_BLAS.F90
+++ b/src/modules/BLAS95/src/F95_BLAS.F90
@@ -40,6 +40,7 @@ MODULE F95_BLAS
PUBLIC :: AXPY
PUBLIC :: ASUM
PUBLIC :: GEMV
+PUBLIC :: GEMM
#ifndef USE_NativeBLAS
PUBLIC :: IAMIN
@@ -204,6 +205,24 @@ MODULE F95_BLAS
END INTERFACE GEMV
#endif
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE GEMM
+ MODULE PROCEDURE SGEMM_F95, DGEMM_F95, CGEMM_F95, ZGEMM_F95
+END INTERFACE GEMM
+
+! #ifdef USE_INTEL_MKL
+! INTERFACE GEMV
+! MODULE PROCEDURE SCGEMV_F95, DZGEMV_F95
+! END INTERFACE GEMV
+! #endif
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
CONTAINS
#ifndef USE_APPLE_NativeBLAS
diff --git a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90 b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90
index 703f34c6c..6a1b4b190 100644
--- a/src/modules/BaseContinuity/src/BaseContinuity_Method.F90
+++ b/src/modules/BaseContinuity/src/BaseContinuity_Method.F90
@@ -18,12 +18,23 @@
MODULE BaseContinuity_Method
USE ErrorHandling, ONLY: Errormsg
-USE GlobalData
+
+USE GlobalData, ONLY: I4B, LGT, stderr
+
USE String_Class, ONLY: String
-USE BaseType
-USE Utility, ONLY: UpperCase
+
+USE BaseType, ONLY: BaseContinuity_, &
+ H1_, &
+ HCURL_, &
+ HDIV_, &
+ DG_
+
+USE StringUtility, ONLY: UpperCase
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: ASSIGNMENT(=)
PUBLIC :: BaseContinuity_ToString
PUBLIC :: BaseContinuity_FromString
@@ -47,26 +58,28 @@ FUNCTION BaseContinuityPointer_FromString(name) RESULT(ans)
CHARACTER(*), INTENT(IN) :: name
CLASS(BaseContinuity_), POINTER :: ans
!!
- TYPE(String) :: astr
- astr = TRIM(UpperCase(name))
+ CHARACTER(len=2) :: astr
- SELECT CASE (astr%chars())
+ astr = UpperCase(name(1:2))
+
+ SELECT CASE (astr)
CASE ("H1")
ALLOCATE (H1_ :: ans)
- CASE ("HDIV")
+
+ CASE ("HD")
ALLOCATE (HDiv_ :: ans)
- CASE ("HCURL")
+
+ CASE ("HC")
ALLOCATE (HCurl_ :: ans)
+
CASE ("DG")
ALLOCATE (DG_ :: ans)
+
CASE DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for given name="//astr, &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseContinuityPointer_FromString()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for given name="//astr, &
+ routine="BaseContinuityPointer_FromString()", &
+ line=__LINE__, unitno=stderr, file=__FILE__)
+ STOP
END SELECT
END FUNCTION BaseContinuityPointer_FromString
@@ -89,20 +102,21 @@ SUBROUTINE BaseContinuity_Copy(obj1, obj2)
SELECT TYPE (obj2)
CLASS IS (H1_)
ALLOCATE (H1_ :: obj1)
+
CLASS IS (HDiv_)
ALLOCATE (HDiv_ :: obj1)
+
CLASS IS (HCurl_)
ALLOCATE (HCurl_ :: obj1)
+
CLASS IS (DG_)
ALLOCATE (DG_ :: obj1)
+
CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of obj2", &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseContinuity_Copy()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for type of obj2", &
+ routine="BaseContinuity_Copy()", line=__LINE__, &
+ unitno=stderr, file=__FILE__)
+ STOP
END SELECT
END SUBROUTINE BaseContinuity_Copy
@@ -118,6 +132,7 @@ END SUBROUTINE BaseContinuity_Copy
FUNCTION BaseContinuity_ToString(obj) RESULT(ans)
CLASS(BaseContinuity_), INTENT(IN) :: obj
TYPE(String) :: ans
+
SELECT TYPE (obj)
CLASS IS (H1_)
ans = "H1"
@@ -128,13 +143,10 @@ FUNCTION BaseContinuity_ToString(obj) RESULT(ans)
CLASS IS (DG_)
ans = "DG"
CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of obj", &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseContinuity_toString()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for type of obj", &
+ routine="BaseContinuity_toString()", &
+ line=__LINE__, unitno=stderr, file=__FILE__)
+ STOP
END SELECT
END FUNCTION BaseContinuity_ToString
@@ -147,30 +159,34 @@ END FUNCTION BaseContinuity_ToString
! summary: Returns a string name of base interpolation type
SUBROUTINE BaseContinuity_FromString(obj, name)
- CLASS(BaseContinuity_), ALLOCATABLE, INTENT(OUT) :: obj
+ CLASS(BaseContinuity_), ALLOCATABLE, INTENT(INOUT) :: obj
CHARACTER(*), INTENT(IN) :: name
- TYPE(String) :: ans
- ans = UpperCase(name)
+ CHARACTER(len=2) :: ans
+
+ ans = UpperCase(name(1:2))
+
IF (ALLOCATED(obj)) DEALLOCATE (obj)
- SELECT CASE (ans%chars())
+ SELECT CASE (ans)
+
CASE ("H1")
ALLOCATE (H1_ :: obj)
- CASE ("HDIV")
+
+ CASE ("HD")
ALLOCATE (HDiv_ :: obj)
- CASE ("HCURL")
+
+ CASE ("HC")
ALLOCATE (HCurl_ :: obj)
+
CASE ("DG")
ALLOCATE (DG_ :: obj)
+
CASE DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for given name="//TRIM(name), &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseContinuity_fromString()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for given name="//TRIM(name), &
+ routine="BaseContinuity_fromString()", &
+ line=__LINE__, unitno=stderr, file=__FILE__)
+ STOP
END SELECT
END SUBROUTINE BaseContinuity_FromString
diff --git a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90 b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90
index cf3eb88a5..0b77c81b1 100644
--- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90
+++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90
@@ -18,25 +18,44 @@
MODULE BaseInterpolation_Method
USE ErrorHandling, ONLY: Errormsg
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT, stdout, stderr
USE String_Class, ONLY: String
-USE BaseType
-USE Utility, ONLY: UpperCase
+USE StringUtility, ONLY: UpperCase
USE Display_Method, ONLY: Tostring
+USE BaseType, ONLY: poly => TypePolynomialOpt, &
+ ip => TypeQuadratureOpt, &
+ BaseInterpolation_, &
+ LagrangeInterpolation_, &
+ SerendipityInterpolation_, &
+ HermitInterpolation_, &
+ HierarchyInterpolation_, &
+ OrthogonalInterpolation_
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: ASSIGNMENT(=)
PUBLIC :: BaseInterpolation_ToInteger
PUBLIC :: BaseInterpolation_FromInteger
-PUBLIC :: BaseInterpolation_ToString
PUBLIC :: BaseInterpolation_FromString
PUBLIC :: BaseInterpolationPointer_FromString
+PUBLIC :: BaseType_ToInteger
+
+PUBLIC :: BaseInterpolation_ToString
+PUBLIC :: BaseType_ToChar
+PUBLIC :: BaseInterpolation_ToChar
INTERFACE BaseInterpolation_ToInteger
MODULE PROCEDURE BaseInterpolation_ToInteger1
MODULE PROCEDURE BaseInterpolation_ToInteger2
END INTERFACE BaseInterpolation_ToInteger
+INTERFACE BaseType_ToInteger
+ MODULE PROCEDURE BaseInterpolation_ToInteger1
+ MODULE PROCEDURE BaseType_ToInteger1
+END INTERFACE BaseType_ToInteger
+
INTERFACE BaseInterpolation_ToString
MODULE PROCEDURE BaseInterpolation_ToString1
MODULE PROCEDURE BaseInterpolation_ToString2
@@ -59,36 +78,35 @@ MODULE BaseInterpolation_Method
FUNCTION BaseInterpolationPointer_FromString(name) RESULT(Ans)
CHARACTER(*), INTENT(IN) :: name
CLASS(BaseInterpolation_), POINTER :: ans
- !!
- TYPE(String) :: astr
- astr = TRIM(UpperCase(name))
- SELECT CASE (astr%chars())
- CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION")
+ CHARACTER(LEN=4) :: astr
+
+ astr = UpperCase(name(1:4))
+
+ SELECT CASE (astr)
+
+ CASE ("LAGR")
ALLOCATE (LagrangeInterpolation_ :: ans)
- CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION")
+
+ CASE ("SERE")
ALLOCATE (SerendipityInterpolation_ :: ans)
- CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION")
+
+ CASE ("HERM")
ALLOCATE (HermitInterpolation_ :: ans)
- CASE ( &
- & "HIERARCHICALPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHICALPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION")
+
+ CASE ("HIER", "HEIR")
ALLOCATE (HierarchyInterpolation_ :: ans)
- CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION")
+
+ CASE ("ORTH")
ALLOCATE (OrthogonalInterpolation_ :: ans)
+
CASE DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of name="//astr, &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseInterpolationPointer_FromString()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for type of name="//astr, &
+ routine="BaseInterpolationPointer_FromString()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+ STOP
END SELECT
+
END FUNCTION BaseInterpolationPointer_FromString
!----------------------------------------------------------------------------
@@ -107,94 +125,99 @@ SUBROUTINE BaseInterpolation_Copy(obj1, obj2)
DEALLOCATE (obj1)
END IF
- SELECT TYPE (obj2)
- CLASS IS (LagrangeInterpolation_)
- ALLOCATE (LagrangeInterpolation_ :: obj1)
- CLASS IS (SerendipityInterpolation_)
- ALLOCATE (SerendipityInterpolation_ :: obj1)
- CLASS IS (HermitInterpolation_)
- ALLOCATE (HermitInterpolation_ :: obj1)
- CLASS IS (HierarchyInterpolation_)
- ALLOCATE (HierarchyInterpolation_ :: obj1)
- CLASS IS (OrthogonalInterpolation_)
- ALLOCATE (OrthogonalInterpolation_ :: obj1)
- CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of obj2", &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseInterpolation_Copy()", &
- & file=__FILE__ &
- & )
+ ALLOCATE (obj1, source=obj2)
- END SELECT
END SUBROUTINE BaseInterpolation_Copy
!----------------------------------------------------------------------------
-! BaseInterpolation_toString
+! BaseInterpolation_toInteger
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-08-09
! summary: Returns a string name of base interpolation type
-FUNCTION BaseInterpolation_ToString1(obj) RESULT(ans)
+FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans)
CLASS(BaseInterpolation_), INTENT(IN) :: obj
- TYPE(String) :: ans
+ INTEGER(I4B) :: ans
+
SELECT TYPE (obj)
CLASS IS (LagrangeInterpolation_)
- ans = "LagrangeInterpolation"
+ ans = poly%lagrange
+
CLASS IS (SerendipityInterpolation_)
- ans = "SerendipityInterpolation"
+ ans = poly%serendipity
+
CLASS IS (HermitInterpolation_)
- ans = "HermitInterpolation"
+ ans = poly%hermit
+
CLASS IS (HierarchyInterpolation_)
- ans = "HierarchyInterpolation"
+ ans = poly%hierarchical
+
CLASS IS (OrthogonalInterpolation_)
- ans = "OrthogonalInterpolation"
+ ans = poly%orthogonal
+
CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of obj2", &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseInterpolation_tostring()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for type of obj2", &
+ routine="BaseInterpolation_toInteger()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+
+ STOP
+
END SELECT
-END FUNCTION BaseInterpolation_ToString1
+END FUNCTION BaseInterpolation_ToInteger1
!----------------------------------------------------------------------------
-! BaseInterpolation_toInteger
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-08-09
-! summary: Returns a string name of base interpolation type
-
-FUNCTION BaseInterpolation_ToInteger1(obj) RESULT(ans)
- CLASS(BaseInterpolation_), INTENT(IN) :: obj
+FUNCTION BaseType_ToInteger1(name) RESULT(ans)
+ CHARACTER(*), INTENT(IN) :: name
INTEGER(I4B) :: ans
- SELECT TYPE (obj)
- CLASS IS (LagrangeInterpolation_)
- ans = LagrangePolynomial
- CLASS IS (SerendipityInterpolation_)
- ans = SerendipityPolynomial
- CLASS IS (HermitInterpolation_)
- ans = HermitPolynomial
- CLASS IS (HierarchyInterpolation_)
- ans = HeirarchicalPolynomial
- CLASS IS (OrthogonalInterpolation_)
- ans = OrthogonalPolynomial
- CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of obj2", &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseInterpolation_toInteger()", &
- & file=__FILE__ &
- & )
+
+ CHARACTER(4) :: astr
+
+ astr = UpperCase(name(1:4))
+
+ SELECT CASE (astr)
+ CASE ("MONO")
+ ans = poly%monomial
+
+ CASE ("LAGR")
+ ans = poly%lagrange
+
+ CASE ("SERE")
+ ans = poly%serendipity
+
+ CASE ("HERM")
+ ans = poly%hermit
+
+ CASE ("HIER", "HEIR")
+ ans = poly%hierarchical
+
+ CASE ("ORTH")
+ ans = poly%orthogonal
+
+ CASE ("LEGE")
+ ans = poly%legendre
+
+ CASE ("JACO")
+ ans = poly%jacobi
+
+ CASE ("ULTR")
+ ans = poly%ultraspherical
+
+ CASE ("CHEB")
+ ans = poly%chebyshev
+
+ CASE DEFAULT
+ CALL ErrorMsg(msg="NO CASE FOUND for name: "//astr, &
+ routine="BaseType_ToInteger1()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
+
END SELECT
-END FUNCTION BaseInterpolation_ToInteger1
+END FUNCTION BaseType_ToInteger1
!----------------------------------------------------------------------------
! BaseInterpolation_toInteger
@@ -208,242 +231,343 @@ FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans)
CHARACTER(*), INTENT(IN) :: name
INTEGER(I4B) :: ans
- SELECT CASE (TRIM(UpperCase(name)))
+ CHARACTER(:), ALLOCATABLE :: astr
+
+ astr = UpperCase(name)
+
+ SELECT CASE (astr)
+
CASE ("EQUIDISTANCE")
- ans = Equidistance
+ ans = ip%equidistance
CASE ("GAUSSLEGENDRE")
- ans = GaussLegendre
+ ans = ip%GaussLegendre
CASE ("GAUSSLEGENDRELOBATTO")
- ans = GaussLegendreLobatto
+ ans = ip%GaussLegendreLobatto
CASE ("GAUSSLEGENDRERADAU")
- ans = GaussLegendreRadau
+ ans = ip%GaussLegendreRadau
CASE ("GAUSSLEGENDRERADAULEFT")
- ans = GaussLegendreRadauLeft
+ ans = ip%GaussLegendreRadauLeft
CASE ("GAUSSLEGENDRERADAURIGHT")
- ans = GaussLegendreRadauRight
+ ans = ip%GaussLegendreRadauRight
CASE ("GAUSSCHEBYSHEV")
- ans = GaussChebyshev
+ ans = ip%GaussChebyshev
CASE ("GAUSSCHEBYSHEVLOBATTO")
- ans = GaussChebyshevLobatto
+ ans = ip%GaussChebyshevLobatto
CASE ("GAUSSCHEBYSHEVRADAU")
- ans = GaussChebyshevRadau
+ ans = ip%GaussChebyshevRadau
CASE ("GAUSSCHEBYSHEVRADAULEFT")
- ans = GaussChebyshevRadauLeft
+ ans = ip%GaussChebyshevRadauLeft
CASE ("GAUSSCHEBYSHEVRADAURIGHT")
- ans = GaussChebyshevRadauRight
+ ans = ip%GaussChebyshevRadauRight
CASE ("GAUSSJACOBI")
- ans = GaussJacobi
+ ans = ip%GaussJacobi
CASE ("GAUSSJACOBILOBATTO")
- ans = GaussJacobiLobatto
+ ans = ip%GaussJacobiLobatto
CASE ("GAUSSJACOBIRADAU")
- ans = GaussJacobiRadau
+ ans = ip%GaussJacobiRadau
CASE ("GAUSSJACOBIRADAULEFT")
- ans = GaussJacobiRadauLeft
+ ans = ip%GaussJacobiRadauLeft
CASE ("GAUSSJACOBIRADAURIGHT")
- ans = GaussJacobiRadauRight
+ ans = ip%GaussJacobiRadauRight
CASE ("GAUSSULTRASPHERICAL")
- ans = GaussUltraspherical
+ ans = ip%GaussUltraspherical
CASE ("GAUSSULTRASPHERICALLOBATTO")
- ans = GaussUltrasphericalLobatto
+ ans = ip%GaussUltrasphericalLobatto
CASE ("GAUSSULTRASPHERICALRADAU")
- ans = GaussUltrasphericalRadau
+ ans = ip%GaussUltrasphericalRadau
CASE ("GAUSSULTRASPHERICALRADAULEFT")
- ans = GaussUltrasphericalRadauLeft
+ ans = ip%GaussUltrasphericalRadauLeft
CASE ("GAUSSULTRASPHERICALRADAURIGHT")
- ans = GaussUltrasphericalRadauRight
+ ans = ip%GaussUltrasphericalRadauRight
CASE DEFAULT
+
ans = -1_I4B
- CALL Errormsg(&
- & msg="No case found for given baseInterpolation name", &
- & file=__FILE__, &
- & line=__LINE__,&
- & routine="BaseInterpolation_ToInteger2()", &
- & unitno=stderr)
- RETURN
+ ! CALL Errormsg(msg="No case found for baseInterpolation ="//name, &
+ ! routine="BaseInterpolation_ToInteger2()", &
+ ! file=__FILE__, line=__LINE__, unitno=stderr)
+ ! STOP
END SELECT
+
+ astr = ""
END FUNCTION BaseInterpolation_ToInteger2
!----------------------------------------------------------------------------
-! BaseInterpolation_fromString
+! BaseInterpolation_fromInteger
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-08-09
! summary: Returns a string name of base interpolation type
-SUBROUTINE BaseInterpolation_FromString(obj, name)
+SUBROUTINE BaseInterpolation_FromInteger(obj, name)
CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: name
+
+ SELECT CASE (name)
+ CASE (poly%lagrange)
+ ALLOCATE (LagrangeInterpolation_ :: obj)
+
+ CASE (poly%serendipity)
+ ALLOCATE (SerendipityInterpolation_ :: obj)
+
+ CASE (poly%hermit)
+ ALLOCATE (HermitInterpolation_ :: obj)
+
+ CASE (poly%orthogonal)
+ ALLOCATE (OrthogonalInterpolation_ :: obj)
+
+ CASE (poly%hierarchical)
+ ALLOCATE (HierarchyInterpolation_ :: obj)
+
+ CASE DEFAULT
+ CALL ErrorMsg(msg="NO CASE FOUND for given name="//tostring(name), &
+ routine="BaseInterpolation_fromInteger()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
+ END SELECT
+
+END SUBROUTINE BaseInterpolation_FromInteger
+
+!----------------------------------------------------------------------------
+! BaseInterpolation_fromString
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-09
+! summary: Returns a string name of base interpolation type
+
+SUBROUTINE BaseInterpolation_FromString(obj, name)
+ CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(INOUT) :: obj
CHARACTER(*), INTENT(IN) :: name
- TYPE(String) :: ans
- ans = UpperCase(name)
+ CHARACTER(4) :: ans
+
+ ans = UpperCase(name(1:4))
+
IF (ALLOCATED(obj)) DEALLOCATE (obj)
- SELECT CASE (ans%chars())
- CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION")
+ SELECT CASE (ans)
+
+ CASE ("LAGR")
ALLOCATE (LagrangeInterpolation_ :: obj)
- CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION")
+
+ CASE ("SERE")
ALLOCATE (SerendipityInterpolation_ :: obj)
- CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION")
+
+ CASE ("HERM")
ALLOCATE (HermitInterpolation_ :: obj)
- CASE ( &
- & "HIERARCHICALPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHICALPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION")
+
+ CASE ("HIER", "HEIR")
ALLOCATE (HierarchyInterpolation_ :: obj)
- CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION")
+
+ CASE ("ORTH")
ALLOCATE (OrthogonalInterpolation_ :: obj)
+
CASE DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for type of name="//TRIM(name), &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseInterpolation_fromString()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="NO CASE FOUND for type of name="//name, &
+ routine="BaseInterpolation_fromString()", &
+ line=__LINE__, unitno=stderr, file=__FILE__)
+ STOP
END SELECT
+
END SUBROUTINE BaseInterpolation_FromString
!----------------------------------------------------------------------------
-! BaseInterpolation_fromInteger
+! BaseInterpolation_toString
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-08-09
! summary: Returns a string name of base interpolation type
-SUBROUTINE BaseInterpolation_FromInteger(obj, name)
- CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(OUT) :: obj
+FUNCTION BaseInterpolation_ToString1(obj) RESULT(ans)
+ CLASS(BaseInterpolation_), INTENT(IN) :: obj
+ TYPE(String) :: ans
+
+ SELECT TYPE (obj)
+ CLASS IS (LagrangeInterpolation_)
+ ans = "LagrangeInterpolation"
+
+ CLASS IS (SerendipityInterpolation_)
+ ans = "SerendipityInterpolation"
+
+ CLASS IS (HermitInterpolation_)
+ ans = "HermitInterpolation"
+
+ CLASS IS (HierarchyInterpolation_)
+ ans = "HierarchyInterpolation"
+
+ CLASS IS (OrthogonalInterpolation_)
+ ans = "OrthogonalInterpolation"
+
+ CLASS DEFAULT
+ CALL ErrorMsg(msg="No Case Found For Type of obj2", &
+ routine="BaseInterpolation_ToString1()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
+ END SELECT
+
+END FUNCTION BaseInterpolation_ToString1
+
+!----------------------------------------------------------------------------
+! BaseType_ToChar
+!----------------------------------------------------------------------------
+
+FUNCTION BaseType_ToChar(name) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: name
+ CHARACTER(:), ALLOCATABLE :: ans
SELECT CASE (name)
- CASE (LagrangePolynomial)
- ALLOCATE (LagrangeInterpolation_ :: obj)
- CASE (SerendipityPolynomial)
- ALLOCATE (SerendipityInterpolation_ :: obj)
- CASE (HermitPolynomial)
- ALLOCATE (HermitInterpolation_ :: obj)
- CASE (OrthogonalPolynomial)
- ALLOCATE (OrthogonalInterpolation_ :: obj)
- CASE (HeirarchicalPolynomial)
- ALLOCATE (HierarchyInterpolation_ :: obj)
+ CASE (poly%monomial)
+ ans = "Monomial"
+
+ CASE (poly%lagrange)
+ ans = "LagrangeInterpolation"
+
+ CASE (poly%serendipity)
+ ans = "SerendipityInterpolation"
+
+ CASE (poly%hermit)
+ ans = "HermitInterpolation"
+
+ CASE (poly%hierarchical)
+ ans = "HierarchyInterpolation"
+
+ CASE (poly%orthogonal)
+ ans = "OrthogonalInterpolation"
+
+ CASE (poly%legendre)
+ ans = "LegendreInterpolation"
+
+ CASE (poly%jacobi)
+ ans = "JacobiInterpolation"
+
+ CASE (poly%ultraspherical)
+ ans = "UltrasphericalInterpolation"
+
+ CASE (poly%chebyshev)
+ ans = "ChebyshevInterpolation"
+
CASE DEFAULT
- CALL ErrorMsg(&
- & msg="NO CASE FOUND for given name="//tostring(name), &
- & line=__LINE__, &
- & unitno=stdout, &
- & routine="BaseInterpolation_fromInteger()", &
- & file=__FILE__ &
- & )
+ CALL ErrorMsg(msg="No Case Found For name "//tostring(name), &
+ routine="BaseType_ToChar()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
END SELECT
-END SUBROUTINE BaseInterpolation_FromInteger
+END FUNCTION BaseType_ToChar
!----------------------------------------------------------------------------
-! QuadraturePointIDToName
+! QuadraturePointIDToName
!----------------------------------------------------------------------------
FUNCTION BaseInterpolation_ToString2(name) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: name
TYPE(String) :: ans
+ ans = BaseInterpolation_ToChar(name)
+END FUNCTION BaseInterpolation_ToString2
+
+!----------------------------------------------------------------------------
+! BaseInterpolation_ToChar
+!----------------------------------------------------------------------------
+
+FUNCTION BaseInterpolation_ToChar(name) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ CHARACTER(:), ALLOCATABLE :: ans
SELECT CASE (name)
- CASE (Equidistance)
- ans = "EQUIDISTANCE"
+ CASE (ip%equidistance)
+ ans = "Equidistance"
- CASE (GaussLegendre)
- ans = "GAUSSLEGENDRE"
+ CASE (ip%GaussLegendre)
+ ans = "GaussLegendre"
- CASE (GaussLegendreLobatto)
- ans = "GAUSSLEGENDRELOBATTO"
+ CASE (ip%GaussLegendreLobatto)
+ ans = "GaussLegendreLobatto"
- CASE (GaussLegendreRadau)
- ans = "GAUSSLEGENDRERADAU"
+ CASE (ip%GaussLegendreRadau)
+ ans = "GaussLegendreRadau"
- CASE (GaussLegendreRadauLeft)
- ans = "GAUSSLEGENDRERADAULEFT"
+ CASE (ip%GaussLegendreRadauLeft)
+ ans = "GaussLegendreRadauLeft"
- CASE (GaussLegendreRadauRight)
- ans = "GAUSSLEGENDRERADAURIGHT"
+ CASE (ip%GaussLegendreRadauRight)
+ ans = "GaussLegendreRadauRight"
- CASE (GaussChebyshev)
- ans = "GAUSSCHEBYSHEV"
+ CASE (ip%GaussChebyshev)
+ ans = "GaussChebyshev"
- CASE (GaussChebyshevLobatto)
- ans = "GAUSSCHEBYSHEVLOBATTO"
+ CASE (ip%GaussChebyshevLobatto)
+ ans = "GaussChebyshevLobatto"
- CASE (GaussChebyshevRadau)
- ans = "GAUSSCHEBYSHEVRADAU"
+ CASE (ip%GaussChebyshevRadau)
+ ans = "GaussChebyshevRadau"
- CASE (GaussChebyshevRadauLeft)
- ans = "GAUSSCHEBYSHEVRADAULEFT"
+ CASE (ip%GaussChebyshevRadauLeft)
+ ans = "GaussChebyshevRadauLeft"
- CASE (GaussChebyshevRadauRight)
- ans = "GAUSSCHEBYSHEVRADAURIGHT"
+ CASE (ip%GaussChebyshevRadauRight)
+ ans = "GaussChebyshevRadauRight"
- CASE (GaussJacobi)
- ans = "GAUSSJACOBI"
+ CASE (ip%GaussJacobi)
+ ans = "GaussJacobi"
- CASE (GaussJacobiLobatto)
- ans = "GAUSSJACOBILOBATTO"
+ CASE (ip%GaussJacobiLobatto)
+ ans = "GaussJacobiLobatto"
- CASE (GaussJacobiRadau)
- ans = "GAUSSJACOBIRADAU"
+ CASE (ip%GaussJacobiRadau)
+ ans = "GaussJacobiRadau"
- CASE (GaussJacobiRadauLeft)
- ans = "GAUSSJACOBIRADAULEFT"
+ CASE (ip%GaussJacobiRadauLeft)
+ ans = "GaussJacobiRadauLeft"
- CASE (GaussJacobiRadauRight)
- ans = "GAUSSJACOBIRADAURIGHT"
+ CASE (ip%GaussJacobiRadauRight)
+ ans = "GaussJacobiRadauRight"
- CASE (GaussUltraspherical)
- ans = "GAUSSULTRASPHERICAL"
+ CASE (ip%GaussUltraspherical)
+ ans = "GaussUltraspherical"
- CASE (GaussUltrasphericalLobatto)
- ans = "GAUSSULTRASPHERICALLOBATTO"
+ CASE (ip%GaussUltrasphericalLobatto)
+ ans = "GaussUltrasphericalLobatto"
- CASE (GaussUltrasphericalRadau)
- ans = "GAUSSULTRASPHERICALRADAU"
+ CASE (ip%GaussUltrasphericalRadau)
+ ans = "GaussUltrasphericalRadau"
- CASE (GaussUltrasphericalRadauLeft)
- ans = "GAUSSULTRASPHERICALRADAULEFT"
+ CASE (ip%GaussUltrasphericalRadauLeft)
+ ans = "GaussUltrasphericalRadauLeft"
- CASE (GaussUltrasphericalRadauRight)
- ans = "GAUSSULTRASPHERICALRADAURIGHT"
+ CASE (ip%GaussUltrasphericalRadauRight)
+ ans = "GaussUltrasphericalRadauRight"
CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for given quadratureType name", &
- & file=__FILE__, &
- & line=__LINE__,&
- & routine="QuadraturePointIDToName()", &
- & unitno=stderr)
- RETURN
+ CALL Errormsg(msg="No case found for given quadratureType name", &
+ routine="BaseInterpolation_ToChar()", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ ans = ""
+ STOP
END SELECT
-END FUNCTION BaseInterpolation_ToString2
+
+END FUNCTION BaseInterpolation_ToChar
END MODULE BaseInterpolation_Method
diff --git a/src/modules/BaseMethod/src/BaseMethod.F90 b/src/modules/BaseMethod/src/BaseMethod.F90
index 04f1ed78f..05e20dc46 100644
--- a/src/modules/BaseMethod/src/BaseMethod.F90
+++ b/src/modules/BaseMethod/src/BaseMethod.F90
@@ -83,7 +83,7 @@ MODULE BaseMethod
USE OpenMP_Method
USE GlobalData
USE Hashing32
-USE OGPF
+! USE OGPF
USE Test_Method
USE MdEncode_Method
! USE DISPMODULE
diff --git a/src/modules/BaseType/src/BaseType.F90 b/src/modules/BaseType/src/BaseType.F90
index 9e73cb795..9e22b3853 100644
--- a/src/modules/BaseType/src/BaseType.F90
+++ b/src/modules/BaseType/src/BaseType.F90
@@ -189,6 +189,16 @@ MODULE BaseType
PUBLIC :: iface_MatrixFunction
PUBLIC :: Range_
PUBLIC :: Interval1D_
+PUBLIC :: TypePrecondOpt
+PUBLIC :: TypeConvergenceOpt
+PUBLIC :: TypeSolverNameOpt
+PUBLIC :: TypeElemNameOpt
+PUBLIC :: TypePolynomialOpt
+PUBLIC :: TypeQuadratureOpt
+PUBLIC :: TypeInterpolationOpt
+PUBLIC :: TypeFEVariableOpt
+
+INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6
!----------------------------------------------------------------------------
! Math_
@@ -1027,8 +1037,6 @@ END SUBROUTINE highorder_refelem
!
! {!pages/FEVariable_.md!}
-INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6
-
TYPE :: FEVariable_
REAL(DFP), ALLOCATABLE :: val(:)
!! values
@@ -1046,6 +1054,10 @@ END SUBROUTINE highorder_refelem
!! Scalar
!! Vector
!! Matrix
+ INTEGER(I4B) :: len = 0_I4B
+ !! current total size
+ INTEGER(I4B) :: capacity = 0_I4B
+ !! capacity of the val
END TYPE FEVariable_
TYPE(FEVariable_), PARAMETER :: TypeFEVariable = FEVariable_(val=NULL())
@@ -1406,7 +1418,7 @@ END SUBROUTINE highorder_refelem
& Jacobian=NULL())
TYPE :: ShapeDataPointer_
- CLASS(ShapeDataPointer_), POINTER :: ptr => NULL()
+ CLASS(ShapeData_), POINTER :: ptr => NULL()
END TYPE ShapeDataPointer_
!----------------------------------------------------------------------------
@@ -1448,44 +1460,50 @@ END SUBROUTINE highorder_refelem
!{!pages/docs-api/ElemShapeData/ElemshapeData_.md!}
!
TYPE :: ElemShapeData_
+ INTEGER(I4B) :: nsd = 0
+ !! spatial dimension of an element
+ INTEGER(I4B) :: xidim = 0
+ !! xidimension
+ INTEGER(I4B) :: nips = 0
+ !! number of integration points
+ INTEGER(I4B) :: nns = 0
+ !! total degrees of freedom
+ !! number of shape functions
REAL(DFP), ALLOCATABLE :: N(:, :)
- !! Shape function value `N(I, ips)`
+ !! Shape function value `N(I, ips)`
+ !! nrow = nns
+ !! ncol = nips
REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :)
- !! Local derivative of a shape function
+ !! Local derivative of a shape function
+ !! shape = nns, xidim, nips
REAL(DFP), ALLOCATABLE :: jacobian(:, :, :)
- !! Jacobian of mapping `J(:,:,ips)` also $\mathbf{F}_{\Xi x}$
+ !! Jacobian of mapping `J(:,:,ips)` also $\mathbf{F}_{\Xi x}$
+ !! shape = nsd, xidim, nips
REAL(DFP), ALLOCATABLE :: js(:)
- !! Determinant of Jacobian at ips
+ !! Determinant of Jacobian at ips
+ !! nips
REAL(DFP), ALLOCATABLE :: ws(:)
- !! Weighting functions
+ !! Weighting functions
+ !! nips
REAL(DFP), ALLOCATABLE :: dNdXt(:, :, :)
- !! Spatial derivative of shape function
+ !! Spatial derivative of shape function
+ !! shape = nns, nsd, nips
REAL(DFP), ALLOCATABLE :: thickness(:)
- !! Thickness of element
+ !! Thickness of element
+ !! nips
REAL(DFP), ALLOCATABLE :: coord(:, :)
- !! Barycentric coordinate
+ !! Barycentric coordinate
+ !! shape = nsd, nips
REAL(DFP), ALLOCATABLE :: normal(:, :)
- !! Normal in case of facet element
- TYPE(ReferenceElement_) :: refelem
- !! Refererece element
- TYPE(QuadraturePoint_) :: quad
- !! Quadrature points
+ !! Normal in case of facet element
END TYPE ElemShapeData_
-TYPE(ElemShapeData_), PARAMETER :: &
- & TypeElemShapeData = ElemShapeData_( &
- & N=NULL(), &
- & dNdXi=NULL(), &
- & Jacobian=NULL(), &
- & Js=NULL(), &
- & Ws=NULL(), &
- & dNdXt=NULL(), &
- & Thickness=NULL(), &
- & Coord=NULL(), &
- & Normal=NULL())
+TYPE(ElemShapeData_), PARAMETER :: TypeElemShapeData = &
+ ElemShapeData_(N=NULL(), dNdXi=NULL(), Jacobian=NULL(), Js=NULL(), &
+ Ws=NULL(), dNdXt=NULL(), Thickness=NULL(), Coord=NULL(), Normal=NULL())
TYPE :: ElemShapeDataPointer_
- CLASS(ShapeDataPointer_), POINTER :: ptr => NULL()
+ CLASS(ElemShapeData_), POINTER :: ptr => NULL()
END TYPE ElemShapeDataPointer_
!----------------------------------------------------------------------------
@@ -1499,35 +1517,34 @@ END SUBROUTINE highorder_refelem
TYPE, EXTENDS(ElemShapeData_) :: STElemShapeData_
REAL(DFP) :: wt = 0.0
- !! Weight of gauss point in time domain
- REAL(DFP) :: theta = 0.0
- !! Gauss point in time domain
+ !! Weight of gauss point in time domain
+ ! REAL(DFP) :: theta = 0.0
+ ! Gauss point in time domain
REAL(DFP) :: jt = 0.0
- !! Jacobian $\frac{dt}{d\theta}$
+ !! Jacobian $\frac{dt}{d\theta}$
+ INTEGER(I4B) :: nnt = 0
+ !! number of nodes in time domain
REAL(DFP), ALLOCATABLE :: T(:)
- !! Shape function in time domain
+ !! Shape function in time domain
+ !! size is nnt
REAL(DFP), ALLOCATABLE :: dTdTheta(:)
- !! Local shape function derivative in time domain
+ !! Local shape function derivative in time domain
+ !! size if nnt
REAL(DFP), ALLOCATABLE :: dNTdt(:, :, :)
+ !! size is nns, nnt, nips
REAL(DFP), ALLOCATABLE :: dNTdXt(:, :, :, :)
- !! (I, a, i, ips)
+ !! (I, a, i, ips)
+ !! size is nns, nnt, nsd, nips
+ !! dim1 = nns
+ !! dim2 = nnt
+ !! dim3 = nsd
+ !! dim4 = nips
END TYPE STElemShapeData_
-TYPE(STElemShapeData_), PARAMETER :: &
- & TypeSTElemShapeData = STElemShapeData_( &
- & N=NULL(), &
- & dNdXi=NULL(), &
- & Jacobian=NULL(), &
- & Js=NULL(), &
- & Ws=NULL(), &
- & dNdXt=NULL(), &
- & Thickness=NULL(), &
- & Coord=NULL(), &
- & Normal=NULL(), &
- & T=NULL(), &
- & dTdTheta=NULL(), &
- & dNTdt=NULL(), &
- & dNTdXt=NULL())
+TYPE(STElemShapeData_), PARAMETER :: TypeSTElemShapeData = &
+ STElemShapeData_(N=NULL(), dNdXi=NULL(), Jacobian=NULL(), Js=NULL(), &
+ Ws=NULL(), dNdXt=NULL(), Thickness=NULL(), Coord=NULL(), Normal=NULL(), &
+ T=NULL(), dTdTheta=NULL(), dNTdt=NULL(), dNTdXt=NULL())
!----------------------------------------------------------------------------
! Meshquality_
@@ -1590,7 +1607,7 @@ END SUBROUTINE highorder_refelem
!> author: Vikas Sharma, Ph. D.
! date: 4 Sept 2022
-! summary: Multi-indices object is defined
+! summary: Multi-indices object is definedstringclass
TYPE :: MultiIndices_
INTEGER(I4B) :: d
@@ -1741,4 +1758,194 @@ PURE FUNCTION iface_MatrixFunction(x) RESULT(ans)
END FUNCTION iface_MatrixFunction
END INTERFACE
+!----------------------------------------------------------------------------
+! TypePreconOpt
+!----------------------------------------------------------------------------
+
+TYPE :: PrecondOpt_
+ INTEGER(I4B) :: NONE = NO_PRECONDITION
+ INTEGER(I4B) :: left = LEFT_PRECONDITION
+ INTEGER(I4B) :: right = RIGHT_PRECONDITION
+ INTEGER(I4B) :: both = LEFT_RIGHT_PRECONDITION
+ INTEGER(I4B) :: jacobi = PRECOND_JACOBI
+ INTEGER(I4B) :: ilu = PRECOND_ILU
+ INTEGER(I4B) :: ssor = PRECOND_SSOR
+ INTEGER(I4B) :: hybrid = PRECOND_HYBRID
+ INTEGER(I4B) :: is = PRECOND_IS
+ INTEGER(I4B) :: sainv = PRECOND_SAINV
+ INTEGER(I4B) :: saamg = PRECOND_SAAMG
+ INTEGER(I4B) :: iluc = PRECOND_ILUC
+ INTEGER(I4B) :: adds = PRECOND_ADDS
+ INTEGER(I4B) :: ilutp = PRECOND_ILUTP
+ INTEGER(I4B) :: ilud = PRECOND_ILUD
+ INTEGER(I4B) :: iludp = PRECOND_ILUDP
+ INTEGER(I4B) :: ilu0 = PRECOND_ILU0
+ INTEGER(I4B) :: iluk = PRECOND_ILUK
+ INTEGER(I4B) :: ilut = PRECOND_ILUT
+END TYPE PrecondOpt_
+
+TYPE(PrecondOpt_), PARAMETER :: TypePrecondOpt = PrecondOpt_()
+
+!----------------------------------------------------------------------------
+! TypePreconOpt
+!----------------------------------------------------------------------------
+
+TYPE :: ConvergenceOpt_
+ INTEGER(I4B) :: res = convergenceInRes
+ INTEGER(I4B) :: sol = convergenceInSol
+ INTEGER(I4B) :: both = convergenceInResSol
+ INTEGER(I4B) :: relative = relativeConvergence
+ INTEGER(I4B) :: absolute = absoluteConvergence
+END TYPE ConvergenceOpt_
+
+TYPE(ConvergenceOpt_), PARAMETER :: TypeConvergenceOpt = ConvergenceOpt_()
+
+!----------------------------------------------------------------------------
+! SolverNameOpt_
+!----------------------------------------------------------------------------
+
+TYPE SolverNameOpt_
+ INTEGER(I4B) :: cg = LIS_CG
+ INTEGER(I4B) :: bcg = LIS_BCG
+ INTEGER(I4B) :: bicg = LIS_BICG
+ INTEGER(I4B) :: cgs = LIS_CGS
+ INTEGER(I4B) :: bcgstab = LIS_BCGSTAB
+ INTEGER(I4B) :: bicgstab = LIS_BICGSTAB
+ INTEGER(I4B) :: bicgstabl = LIS_BICGSTABL
+ INTEGER(I4B) :: gpbicg = LIS_GPBICG
+ INTEGER(I4B) :: tfqmr = LIS_TFQMR
+ INTEGER(I4B) :: omn = LIS_OMN
+ INTEGER(I4B) :: fom = LIS_FOM
+ INTEGER(I4B) :: orthomin = LIS_ORTHOMIN
+ INTEGER(I4B) :: gmres = LIS_GMRES
+ INTEGER(I4B) :: gmr = LIS_GMR
+ INTEGER(I4B) :: jacobi = LIS_JACOBI
+ INTEGER(I4B) :: gs = LIS_GS
+ INTEGER(I4B) :: sor = LIS_SOR
+ INTEGER(I4B) :: bicgsafe = LIS_BICGSAFE
+ INTEGER(I4B) :: cr = LIS_CR
+ INTEGER(I4B) :: bicr = LIS_BICR
+ INTEGER(I4B) :: crs = LIS_CRS
+ INTEGER(I4B) :: bicrstab = LIS_BICRSTAB
+ INTEGER(I4B) :: gpbicr = LIS_GPBICR
+ INTEGER(I4B) :: bicrsafe = LIS_BICRSAFE
+ INTEGER(I4B) :: fgmres = LIS_FGMRES
+ INTEGER(I4B) :: idrs = LIS_IDRS
+ INTEGER(I4B) :: idr1 = LIS_IDR1
+ INTEGER(I4B) :: minres = LIS_MINRES
+ INTEGER(I4B) :: cocg = LIS_COCG
+ INTEGER(I4B) :: cocr = LIS_COCR
+ INTEGER(I4B) :: cgnr = LIS_CGNR
+ INTEGER(I4B) :: cgn = LIS_CGN
+ INTEGER(I4B) :: dbcg = LIS_DBCG
+ INTEGER(I4B) :: dbicg = LIS_DBICG
+ INTEGER(I4B) :: dqgmres = LIS_DQGMRES
+ INTEGER(I4B) :: superlu = LIS_SUPERLU
+END TYPE SolverNameOpt_
+
+TYPE(SolverNameOpt_), PARAMETER :: TypeSolverNameOpt = &
+ SolverNameOpt_()
+
+!----------------------------------------------------------------------------
+! TypeElemNameOpt
+!----------------------------------------------------------------------------
+
+TYPE :: ElemNameOpt_
+ INTEGER(I4B) :: point = Point
+ INTEGER(I4B) :: line = Line
+ INTEGER(I4B) :: triangle = Triangle
+ INTEGER(I4B) :: quadrangle = Quadrangle
+ INTEGER(I4B) :: tetrahedron = Tetrahedron
+ INTEGER(I4B) :: hexahedron = Hexahedron
+ INTEGER(I4B) :: prism = Prism
+ INTEGER(I4B) :: pyramid = Pyramid
+END TYPE ElemNameOpt_
+
+TYPE(ElemNameOpt_), PARAMETER :: TypeElemNameOpt = ElemNameOpt_()
+
+!----------------------------------------------------------------------------
+! TypePolynomialOpt
+!----------------------------------------------------------------------------
+
+TYPE :: PolynomialOpt_
+ INTEGER(I4B) :: monomial = Monomial
+ INTEGER(I4B) :: lagrange = LagrangePolynomial
+ INTEGER(I4B) :: serendipity = SerendipityPolynomial
+ INTEGER(I4B) :: hierarchical = HierarchicalPolynomial
+ INTEGER(I4B) :: orthogonal = OrthogonalPolynomial
+ INTEGER(I4B) :: jacobi = JacobiPolynomial
+ INTEGER(I4B) :: legendre = LegendrePolynomial
+ INTEGER(I4B) :: chebyshev = ChebyshevPolynomial
+ INTEGER(I4B) :: lobatto = LobattoPolynomial
+ INTEGER(I4B) :: unscaledLobatto = UnscaledLobattoPolynomial
+ INTEGER(I4B) :: hermit = HermitPolynomial
+ INTEGER(I4B) :: ultraspherical = UltrasphericalPolynomial
+END TYPE PolynomialOpt_
+
+TYPE(PolynomialOpt_), PARAMETER :: TypePolynomialOpt = PolynomialOpt_()
+
+!----------------------------------------------------------------------------
+! TypeQuadratureOpt
+!----------------------------------------------------------------------------
+
+TYPE :: QuadratureOpt_
+ INTEGER(I4B) :: equidistance = EquidistanceQP
+ INTEGER(I4B) :: Gauss = GaussQP
+ INTEGER(I4B) :: GaussLegendre = GaussLegendreQP
+ INTEGER(I4B) :: GaussLegendreLobatto = GaussLegendreLobattoQP
+ INTEGER(I4B) :: GaussLegendreRadau = GaussLegendreRadau
+ INTEGER(I4B) :: GaussLegendreRadauLeft = GaussLegendreRadauLeft
+ INTEGER(I4B) :: GaussLegendreRadauRight = GaussLegendreRadauRight
+ INTEGER(I4B) :: GaussRadau = GaussRadauQP
+ INTEGER(I4B) :: GaussRadauLeft = GaussRadauLeftQP
+ INTEGER(I4B) :: GaussRadauRight = GaussRadauRightQP
+ INTEGER(I4B) :: GaussLobatto = GaussLobattoQP
+ INTEGER(I4B) :: GaussChebyshev = GaussChebyshevQP
+ INTEGER(I4B) :: GaussChebyshevLobatto = GaussChebyshevLobattoQP
+ INTEGER(I4B) :: GaussChebyshevRadau = GaussChebyshevRadau
+ INTEGER(I4B) :: GaussChebyshevRadauLeft = GaussChebyshevRadauLeft
+ INTEGER(I4B) :: GaussChebyshevRadauRight = GaussChebyshevRadauRight
+ INTEGER(I4B) :: GaussJacobi = GaussJacobiQP
+ INTEGER(I4B) :: GaussJacobiLobatto = GaussJacobiLobattoQP
+ INTEGER(I4B) :: GaussJacobiRadau = GaussJacobiRadau
+ INTEGER(I4B) :: GaussJacobiRadauLeft = GaussJacobiRadauLeft
+ INTEGER(I4B) :: GaussJacobiRadauRight = GaussJacobiRadauRight
+ INTEGER(I4B) :: GaussUltraSpherical = GaussUltraSphericalQP
+ INTEGER(I4B) :: GaussUltraSphericalLobatto = GaussUltraSphericalLobattoQP
+ INTEGER(I4B) :: GaussUltraSphericalRadau = GaussUltraSphericalRadau
+ INTEGER(I4B) :: GaussUltraSphericalRadauLeft = GaussUltraSphericalRadauLeft
+ INTEGER(I4B) :: GaussUltraSphericalRadauRight = &
+ GaussUltraSphericalRadauRight
+ INTEGER(I4B) :: ChenBabuska = ChenBabuskaQP
+ INTEGER(I4B) :: Hesthaven = HesthavenQP
+ INTEGER(I4B) :: Feket = FeketQP
+ INTEGER(I4B) :: BlythPozLegendre = BlythPozLegendreQP
+ INTEGER(I4B) :: BlythPozChebyshev = BlythPozChebyshevQP
+ INTEGER(I4B) :: IsaacLegendre = IsaacLegendreQP
+ INTEGER(I4B) :: IsaacChebyshev = IsaacChebyshevQP
+END TYPE QuadratureOpt_
+
+TYPE(QuadratureOpt_), PARAMETER :: TypeQuadratureOpt = QuadratureOpt_()
+TYPE(QuadratureOpt_), PARAMETER :: TypeInterpolationOpt = QuadratureOpt_()
+
+!----------------------------------------------------------------------------
+! TypeFeVariableOpt
+!----------------------------------------------------------------------------
+
+TYPE :: FEVariableOpt_
+ INTEGER(I4B) :: scalar = scalar
+ INTEGER(I4B) :: vector = vector
+ INTEGER(I4B) :: matrix = matrix
+ INTEGER(I4B) :: nodal = nodal
+ INTEGER(i4b) :: quadrature = quadrature
+ INTEGER(I4B) :: constant = constant
+ INTEGER(I4B) :: space = space
+ INTEGER(I4B) :: time = time
+ INTEGER(I4B) :: spacetime = spacetime
+ INTEGER(I4B) :: solutionDependent = solutionDependent
+ INTEGER(I4B) :: randomSpace = randomSpace
+END TYPE FEVariableOpt_
+
+TYPE(FEVariableOpt_), PARAMETER :: TypeFEVariableOpt = FEVariableOpt_()
+
END MODULE BaseType
diff --git a/src/modules/BeFoR64/src/befor64.F90 b/src/modules/BeFoR64/src/befor64.F90
index 1ed72dc2d..744db0d23 100644
--- a/src/modules/BeFoR64/src/befor64.F90
+++ b/src/modules/BeFoR64/src/befor64.F90
@@ -1,21 +1,21 @@
!< BeFoR64, Base64 encoding/decoding library for FoRtran poor people.
-module befor64
+MODULE befor64
!< BeFoR64, Base64 encoding/decoding library for FoRtran poor people.
-use penf
-use befor64_pack_data_m
+USE penf
+USE befor64_pack_data_m
-implicit none
-private
-public :: is_b64_initialized, b64_init
-public :: b64_encode, b64_encode_up
-public :: b64_decode, b64_decode_up
-public :: pack_data
+IMPLICIT NONE
+PRIVATE
+PUBLIC :: is_b64_initialized, b64_init
+PUBLIC :: b64_encode, b64_encode_up
+PUBLIC :: b64_decode, b64_decode_up
+PUBLIC :: pack_data
-logical :: is_b64_initialized=.false. !< Flag for checking the initialization of the library.
+LOGICAL :: is_b64_initialized = .FALSE. !< Flag for checking the initialization of the library.
character(64) :: base64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" !< Base64 alphabet.
-interface b64_encode
+INTERFACE b64_encode
!< Encode numbers (integer and real) to base64.
!<
!< This is an interface for encoding integer and real numbers of any kinds into a base64 string. This interface can encode both
@@ -48,20 +48,20 @@ module befor64
!< procedure.
!<
!< @warning The encoding of array of strings is admitted only if each string of the array has the same length.
- module procedure &
+ MODULE PROCEDURE &
#if defined _R16P
- b64_encode_R16, b64_encode_R16_a, &
+ b64_encode_R16, b64_encode_R16_a, &
#endif
- b64_encode_R8, b64_encode_R8_a, &
- b64_encode_R4, b64_encode_R4_a, &
- b64_encode_I8, b64_encode_I8_a, &
- b64_encode_I4, b64_encode_I4_a, &
- b64_encode_I2, b64_encode_I2_a, &
- b64_encode_I1, b64_encode_I1_a, &
- b64_encode_string, b64_encode_string_a
-endinterface
-
-interface b64_encode_up
+ b64_encode_R8, b64_encode_R8_a, &
+ b64_encode_R4, b64_encode_R4_a, &
+ b64_encode_I8, b64_encode_I8_a, &
+ b64_encode_I4, b64_encode_I4_a, &
+ b64_encode_I2, b64_encode_I2_a, &
+ b64_encode_I1, b64_encode_I1_a, &
+ b64_encode_string, b64_encode_string_a
+END INTERFACE
+
+INTERFACE b64_encode_up
!< Encode unlimited polymorphic variable to base64.
!<
!< This is an interface for encoding both scalar and array.
@@ -93,10 +93,10 @@ module befor64
!< procedure.
!<
!< @warning The encoding of array of strings is admitted only if each string of the array has the same length.
- module procedure b64_encode_up, b64_encode_up_a
-endinterface
+ MODULE PROCEDURE b64_encode_up, b64_encode_up_a
+END INTERFACE
-interface b64_decode
+INTERFACE b64_decode
!< Decode numbers (integer and real) from base64.
!<
!< This is an interface for decoding integer and real numbers of any kinds from a base64 string. This interface can decode both
@@ -126,20 +126,20 @@ module befor64
!< procedure.
!<
!< @warning The decoding of array of strings is admitted only if each string of the array has the same length.
- module procedure &
+ MODULE PROCEDURE &
#if defined _R16P
- b64_decode_R16, b64_decode_R16_a, &
+ b64_decode_R16, b64_decode_R16_a, &
#endif
- b64_decode_R8, b64_decode_R8_a, &
- b64_decode_R4, b64_decode_R4_a, &
- b64_decode_I8, b64_decode_I8_a, &
- b64_decode_I4, b64_decode_I4_a, &
- b64_decode_I2, b64_decode_I2_a, &
- b64_decode_I1, b64_decode_I1_a, &
- b64_decode_string, b64_decode_string_a
-endinterface
-
-interface b64_decode_up
+ b64_decode_R8, b64_decode_R8_a, &
+ b64_decode_R4, b64_decode_R4_a, &
+ b64_decode_I8, b64_decode_I8_a, &
+ b64_decode_I4, b64_decode_I4_a, &
+ b64_decode_I2, b64_decode_I2_a, &
+ b64_decode_I1, b64_decode_I1_a, &
+ b64_decode_string, b64_decode_string_a
+END INTERFACE
+
+INTERFACE b64_decode_up
!< Decode unlimited polymorphic variable from base64.
!<
!< This is an interface for decoding both scalar and array.
@@ -168,955 +168,955 @@ module befor64
!< procedure.
!<
!< @warning The decoding of array of strings is admitted only if each string of the array has the same length.
- module procedure b64_decode_up, b64_decode_up_a
-endinterface
-
-contains
- subroutine b64_init()
- !< Initialize the BeFoR64 library.
- !<
- !< @note This procedure **must** be called before encoding/decoding anything!
- !<
- !<```fortran
- !< use befor64
- !< call b64_init
- !< print "(L1)", is_b64_initialized
- !<```
- !=> T <<<
-
- if (.not.is_initialized) call penf_init
- is_b64_initialized = .true.
- endsubroutine b64_init
-
- pure subroutine encode_bits(bits, padd, code)
- !< Encode a bits stream (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4).
- !<
- !< The bits stream are encoded in chunks of 24 bits as the following example (in little endian order)
- !<```
- !< +--first octet--+-second octet--+--third octet--+
- !< |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|
- !< +-----------+---+-------+-------+---+-----------+
- !< |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|
- !< +--1.index--+--2.index--+--3.index--+--4.index--+
- !<```
- !< @note The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used.
- !<
- !< @note The number of paddings must be computed outside this procedure, into the calling scope.
- !<
- !< @warning This procedure is the backend of encoding, thus it must be never called outside the module.
- integer(I1P), intent(in) :: bits(1:) !< Bits to be encoded.
- integer(I4P), intent(in) :: padd !< Number of padding characters ('=').
- character(*), intent(out) :: code !< Characters code.
- integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input.
- integer(I8P) :: c !< Counter.
- integer(I8P) :: e !< Counter.
- integer(I8P) :: Nb !< Length of bits array.
-
- Nb=size(bits,dim=1,kind=I8P)
- c = 1_I8P
- do e=1_I8P,Nb,3_I8P ! loop over array elements: 3 bytes (24 bits) scanning
- sixb = 0_I1P
- call mvbits(bits(e ),2,6,sixb(1),0)
- call mvbits(bits(e ),0,2,sixb(2),4)
- if (e+1<=Nb) then
- call mvbits(bits(e+1),4,4,sixb(2),0)
- call mvbits(bits(e+1),0,4,sixb(3),2)
- endif
- if (e+2<=Nb) then
- call mvbits(bits(e+2),6,2,sixb(3),0)
- call mvbits(bits(e+2),0,6,sixb(4),0)
- endif
- sixb = sixb + 1_I1P
- code(c :c ) = base64(sixb(1):sixb(1))
- code(c+1:c+1) = base64(sixb(2):sixb(2))
- code(c+2:c+2) = base64(sixb(3):sixb(3))
- code(c+3:c+3) = base64(sixb(4):sixb(4))
- c = c + 4_I8P
- enddo
- if (padd>0) code(len(code)-padd+1:)=repeat('=',padd)
- endsubroutine encode_bits
-
- pure subroutine decode_bits(code, bits)
- !< Decode a base64 string into a sequence of bits stream.
- !<
- !< The base64 string must be parsed with a strike of 4 characters and converted into a 3 bytes stream. Considering the base64 code
- !< `QUJD` the decoding process must do
- !<```
- !< +-b64 char--+-b64 char--+-b64 char--+-b64 char--+
- !< | Q | U | J | D |
- !< +-b64 index-+-b64 index-+-b64 index-+-b64 index-+
- !< ! 16 | 20 | 9 | 3 |
- !< +-6 bits----+-6 bits----+-6 bits----+-6 bits----+
- !< |0 1 0 0 0 0|0 1 0 1 0 0|0 0 1 0 0 1|0 0 0 0 1 1|
- !< +-----------+---+-------+-------+---+-----------+
- !< |0 1 0 0 0 0 0 1|0 1 0 0 0 0 1 0|0 1 0 0 0 0 1 1|
- !< +-----8 bits----+-----8 bits----+-----8 bits----+
- !<```
- !< @note The bits pattern is returned as a 1-byte element array, the dimension of witch must be computed outside this procedure.
- !<
- !< @warning This procedure is the backend of decoding, thus it must be never called outside the module.
- character(*), intent(in) :: code !< Characters code.
- integer(I1P), intent(out) :: bits(1:) !< Bits decoded.
- integer(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input.
- integer(I8P) :: c !< Counter.
- integer(I8P) :: e !< Counter.
- integer(I8P) :: Nb !< Length of bits array.
-
- Nb=size(bits,dim=1,kind=I8P)
- e = 1_I8P
- do c=1_I8P,len(code),4_I8P ! loop over code characters: 3 bytes (24 bits) scanning
- sixb = 0_I1P
- sixb(1) = index(base64,code(c :c )) - 1
- sixb(2) = index(base64,code(c+1:c+1)) - 1
- sixb(3) = index(base64,code(c+2:c+2)) - 1
- sixb(4) = index(base64,code(c+3:c+3)) - 1
- call mvbits(sixb(1),0,6,bits(e ),2) ; call mvbits(sixb(2),4,2,bits(e ),0)
- if (e+1<=Nb) then
- call mvbits(sixb(2),0,4,bits(e+1),4) ; call mvbits(sixb(3),2,4,bits(e+1),0)
- endif
- if (e+2<=Nb) then
- call mvbits(sixb(3),0,2,bits(e+2),6) ; call mvbits(sixb(4),0,6,bits(e+2),0)
- endif
- e = e + 3_I8P
- enddo
- endsubroutine decode_bits
-
- subroutine b64_encode_up(up, code)
- !< Encode an unlimited polymorphic scalar to base64.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode_up(up=1._R8P, code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAAAA8D8= <<<
- class(*), intent(in) :: up !< Unlimited polymorphic variable to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
-
- select type(up)
- type is(real(R8P))
- call b64_encode_R8(n=up,code=code)
- type is(real(R4P))
- call b64_encode_R4(n=up,code=code)
- type is(integer(I8P))
- call b64_encode_I8(n=up,code=code)
- type is(integer(I4P))
- call b64_encode_I4(n=up,code=code)
- type is(integer(I2P))
- call b64_encode_I2(n=up,code=code)
- type is(integer(I1P))
- call b64_encode_I1(n=up,code=code)
- type is(character(*))
- call b64_encode_string(s=up,code=code)
- endselect
- endsubroutine b64_encode_up
-
- pure subroutine b64_encode_up_a(up, code)
- !< Encode an unlimited polymorphic array to base64.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode_up(up=[0._R4P,-32.12_R4P], code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAOF6AMI= <<<
- class(*), intent(in) :: up(1:) !< Unlimited polymorphic variable to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
-
- select type(up)
- type is(real(R8P))
- call b64_encode_R8_a(n=up,code=code)
- type is(real(R4P))
- call b64_encode_R4_a(n=up,code=code)
- type is(integer(I8P))
- call b64_encode_I8_a(n=up,code=code)
- type is(integer(I4P))
- call b64_encode_I4_a(n=up,code=code)
- type is(integer(I2P))
- call b64_encode_I2_a(n=up,code=code)
- type is(integer(I1P))
- call b64_encode_I1_a(n=up,code=code)
- type is(character(*))
- call b64_encode_string_a(s=up,code=code)
- endselect
- endsubroutine b64_encode_up_a
-
- subroutine b64_decode_up(code, up)
- !< Decode an unlimited polymorphic scalar from base64.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: scalar_I4
- !< call b64_decode_up(code='5wcAAA==',up=scalar_I4)
- !< print "(L1)", scalar_I4==2023_I4P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- class(*), intent(out) :: up !< Unlimited polymorphic variable to be decoded.
-
- select type(up)
- type is(real(R8P))
- call b64_decode_R8(code=code,n=up)
- type is(real(R4P))
- call b64_decode_R4(code=code,n=up)
- type is(integer(I8P))
- call b64_decode_I8(code=code,n=up)
- type is(integer(I4P))
- call b64_decode_I4(code=code,n=up)
- type is(integer(I2P))
- call b64_decode_I2(code=code,n=up)
- type is(integer(I1P))
- call b64_decode_I1(code=code,n=up)
- type is(character(*))
- call b64_decode_string(code=code,s=up)
- endselect
- endsubroutine b64_decode_up
-
- subroutine b64_decode_up_a(code, up)
- !< Decode an unlimited polymorphic array from base64.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: array_I8(1:4)
- !< call b64_decode_up(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=', up=array_I8)
- !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- class(*), intent(out) :: up(1:) !< Unlimited polymorphic variable to be decoded.
-
- select type(up)
- type is(real(R8P))
- call b64_decode_R8_a(code=code,n=up)
- type is(real(R4P))
- call b64_decode_R4_a(code=code,n=up)
- type is(integer(I8P))
- call b64_decode_I8_a(code=code,n=up)
- type is(integer(I4P))
- call b64_decode_I4_a(code=code,n=up)
- type is(integer(I2P))
- call b64_decode_I2_a(code=code,n=up)
- type is(integer(I1P))
- call b64_decode_I1_a(code=code,n=up)
- type is(character(*))
- call b64_decode_string_a(code=code,s=up)
- endselect
- endsubroutine b64_decode_up_a
-
- pure subroutine b64_encode_R16(n, code)
- !< Encode scalar number to base64 (R16P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=134.231_R16P, code=code64)
- !< print "(A)", code64
- !<```
- !=> CKwcWmTHYEA= <<<
- real(R16P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYR16P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYR16P+2)/3)*4)
- nI1P = transfer(n,nI1P)
+ MODULE PROCEDURE b64_decode_up, b64_decode_up_a
+END INTERFACE
+
+CONTAINS
+SUBROUTINE b64_init()
+ !< Initialize the BeFoR64 library.
+ !<
+ !< @note This procedure **must** be called before encoding/decoding anything!
+ !<
+ !<```fortran
+ !< use befor64
+ !< call b64_init
+ !< print "(L1)", is_b64_initialized
+ !<```
+ !=> T <<<
+
+ IF (.NOT. is_initialized) CALL penf_init
+ is_b64_initialized = .TRUE.
+END SUBROUTINE b64_init
+
+PURE SUBROUTINE encode_bits(bits, padd, code)
+ !< Encode a bits stream (must be multiple of 24 bits) into base64 charcaters code (of length multiple of 4).
+ !<
+ !< The bits stream are encoded in chunks of 24 bits as the following example (in little endian order)
+ !<```
+ !< +--first octet--+-second octet--+--third octet--+
+ !< |7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|7 6 5 4 3 2 1 0|
+ !< +-----------+---+-------+-------+---+-----------+
+ !< |5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|5 4 3 2 1 0|
+ !< +--1.index--+--2.index--+--3.index--+--4.index--+
+ !<```
+ !< @note The 4 indexes are stored into 4 elements 8 bits array, thus 2 bits of each array element are not used.
+ !<
+ !< @note The number of paddings must be computed outside this procedure, into the calling scope.
+ !<
+ !< @warning This procedure is the backend of encoding, thus it must be never called outside the module.
+ INTEGER(I1P), INTENT(in) :: bits(1:) !< Bits to be encoded.
+ INTEGER(I4P), INTENT(in) :: padd !< Number of padding characters ('=').
+ CHARACTER(*), INTENT(out) :: code !< Characters code.
+ INTEGER(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input.
+ INTEGER(I8P) :: c !< Counter.
+ INTEGER(I8P) :: e !< Counter.
+ INTEGER(I8P) :: Nb !< Length of bits array.
+
+ Nb = SIZE(bits, dim=1, kind=I8P)
+ c = 1_I8P
+ DO e = 1_I8P, Nb, 3_I8P ! loop over array elements: 3 bytes (24 bits) scanning
+ sixb = 0_I1P
+ CALL MVBITS(bits(e), 2, 6, sixb(1), 0)
+ CALL MVBITS(bits(e), 0, 2, sixb(2), 4)
+ IF (e + 1 <= Nb) THEN
+ CALL MVBITS(bits(e + 1), 4, 4, sixb(2), 0)
+ CALL MVBITS(bits(e + 1), 0, 4, sixb(3), 2)
+ END IF
+ IF (e + 2 <= Nb) THEN
+ CALL MVBITS(bits(e + 2), 6, 2, sixb(3), 0)
+ CALL MVBITS(bits(e + 2), 0, 6, sixb(4), 0)
+ END IF
+ sixb = sixb + 1_I1P
+ code(c:c) = base64(sixb(1):sixb(1))
+ code(c + 1:c + 1) = base64(sixb(2):sixb(2))
+ code(c + 2:c + 2) = base64(sixb(3):sixb(3))
+ code(c + 3:c + 3) = base64(sixb(4):sixb(4))
+ c = c + 4_I8P
+ END DO
+ IF (padd > 0) code(LEN(code) - padd + 1:) = REPEAT('=', padd)
+END SUBROUTINE encode_bits
+
+PURE SUBROUTINE decode_bits(code, bits)
+ !< Decode a base64 string into a sequence of bits stream.
+ !<
+ !< The base64 string must be parsed with a strike of 4 characters and converted into a 3 bytes stream. Considering the base64 code
+ !< `QUJD` the decoding process must do
+ !<```
+ !< +-b64 char--+-b64 char--+-b64 char--+-b64 char--+
+ !< | Q | U | J | D |
+ !< +-b64 index-+-b64 index-+-b64 index-+-b64 index-+
+ !< ! 16 | 20 | 9 | 3 |
+ !< +-6 bits----+-6 bits----+-6 bits----+-6 bits----+
+ !< |0 1 0 0 0 0|0 1 0 1 0 0|0 0 1 0 0 1|0 0 0 0 1 1|
+ !< +-----------+---+-------+-------+---+-----------+
+ !< |0 1 0 0 0 0 0 1|0 1 0 0 0 0 1 0|0 1 0 0 0 0 1 1|
+ !< +-----8 bits----+-----8 bits----+-----8 bits----+
+ !<```
+ !< @note The bits pattern is returned as a 1-byte element array, the dimension of witch must be computed outside this procedure.
+ !<
+ !< @warning This procedure is the backend of decoding, thus it must be never called outside the module.
+ CHARACTER(*), INTENT(in) :: code !< Characters code.
+ INTEGER(I1P), INTENT(out) :: bits(1:) !< Bits decoded.
+ INTEGER(I1P) :: sixb(1:4) !< 6 bits slices (stored into 8 bits integer) of 24 bits input.
+ INTEGER(I8P) :: c !< Counter.
+ INTEGER(I8P) :: e !< Counter.
+ INTEGER(I8P) :: Nb !< Length of bits array.
+
+ Nb = SIZE(bits, dim=1, kind=I8P)
+ e = 1_I8P
+ DO c = 1_I8P, LEN(code), 4_I8P ! loop over code characters: 3 bytes (24 bits) scanning
+ sixb = 0_I1P
+ sixb(1) = INDEX(base64, code(c:c)) - 1
+ sixb(2) = INDEX(base64, code(c + 1:c + 1)) - 1
+ sixb(3) = INDEX(base64, code(c + 2:c + 2)) - 1
+ sixb(4) = INDEX(base64, code(c + 3:c + 3)) - 1
+ CALL MVBITS(sixb(1), 0, 6, bits(e), 2); CALL MVBITS(sixb(2), 4, 2, bits(e), 0)
+ IF (e + 1 <= Nb) THEN
+ CALL MVBITS(sixb(2), 0, 4, bits(e + 1), 4); CALL MVBITS(sixb(3), 2, 4, bits(e + 1), 0)
+ END IF
+ IF (e + 2 <= Nb) THEN
+ CALL MVBITS(sixb(3), 0, 2, bits(e + 2), 6); CALL MVBITS(sixb(4), 0, 6, bits(e + 2), 0)
+ END IF
+ e = e + 3_I8P
+ END DO
+END SUBROUTINE decode_bits
+
+SUBROUTINE b64_encode_up(up, code)
+ !< Encode an unlimited polymorphic scalar to base64.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode_up(up=1._R8P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAAAA8D8= <<<
+ CLASS(*), INTENT(in) :: up !< Unlimited polymorphic variable to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+
+ SELECT TYPE (up)
+ TYPE is (REAL(R8P))
+ CALL b64_encode_R8(n=up, code=code)
+ TYPE is (REAL(R4P))
+ CALL b64_encode_R4(n=up, code=code)
+ TYPE is (INTEGER(I8P))
+ CALL b64_encode_I8(n=up, code=code)
+ TYPE is (INTEGER(I4P))
+ CALL b64_encode_I4(n=up, code=code)
+ TYPE is (INTEGER(I2P))
+ CALL b64_encode_I2(n=up, code=code)
+ TYPE is (INTEGER(I1P))
+ CALL b64_encode_I1(n=up, code=code)
+ TYPE is (CHARACTER(*))
+ CALL b64_encode_string(s=up, code=code)
+ END SELECT
+END SUBROUTINE b64_encode_up
+
+PURE SUBROUTINE b64_encode_up_a(up, code)
+ !< Encode an unlimited polymorphic array to base64.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode_up(up=[0._R4P,-32.12_R4P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAOF6AMI= <<<
+ CLASS(*), INTENT(in) :: up(1:) !< Unlimited polymorphic variable to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+
+ SELECT TYPE (up)
+ TYPE is (REAL(R8P))
+ CALL b64_encode_R8_a(n=up, code=code)
+ TYPE is (REAL(R4P))
+ CALL b64_encode_R4_a(n=up, code=code)
+ TYPE is (INTEGER(I8P))
+ CALL b64_encode_I8_a(n=up, code=code)
+ TYPE is (INTEGER(I4P))
+ CALL b64_encode_I4_a(n=up, code=code)
+ TYPE is (INTEGER(I2P))
+ CALL b64_encode_I2_a(n=up, code=code)
+ TYPE is (INTEGER(I1P))
+ CALL b64_encode_I1_a(n=up, code=code)
+ TYPE is (CHARACTER(*))
+ CALL b64_encode_string_a(s=up, code=code)
+ END SELECT
+END SUBROUTINE b64_encode_up_a
+
+SUBROUTINE b64_decode_up(code, up)
+ !< Decode an unlimited polymorphic scalar from base64.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: scalar_I4
+ !< call b64_decode_up(code='5wcAAA==',up=scalar_I4)
+ !< print "(L1)", scalar_I4==2023_I4P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ CLASS(*), INTENT(out) :: up !< Unlimited polymorphic variable to be decoded.
+
+ SELECT TYPE (up)
+ TYPE is (REAL(R8P))
+ CALL b64_decode_R8(code=code, n=up)
+ TYPE is (REAL(R4P))
+ CALL b64_decode_R4(code=code, n=up)
+ TYPE is (INTEGER(I8P))
+ CALL b64_decode_I8(code=code, n=up)
+ TYPE is (INTEGER(I4P))
+ CALL b64_decode_I4(code=code, n=up)
+ TYPE is (INTEGER(I2P))
+ CALL b64_decode_I2(code=code, n=up)
+ TYPE is (INTEGER(I1P))
+ CALL b64_decode_I1(code=code, n=up)
+ TYPE is (CHARACTER(*))
+ CALL b64_decode_string(code=code, s=up)
+ END SELECT
+END SUBROUTINE b64_decode_up
+
+SUBROUTINE b64_decode_up_a(code, up)
+ !< Decode an unlimited polymorphic array from base64.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: array_I8(1:4)
+ !< call b64_decode_up(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=', up=array_I8)
+ !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ CLASS(*), INTENT(out) :: up(1:) !< Unlimited polymorphic variable to be decoded.
+
+ SELECT TYPE (up)
+ TYPE is (REAL(R8P))
+ CALL b64_decode_R8_a(code=code, n=up)
+ TYPE is (REAL(R4P))
+ CALL b64_decode_R4_a(code=code, n=up)
+ TYPE is (INTEGER(I8P))
+ CALL b64_decode_I8_a(code=code, n=up)
+ TYPE is (INTEGER(I4P))
+ CALL b64_decode_I4_a(code=code, n=up)
+ TYPE is (INTEGER(I2P))
+ CALL b64_decode_I2_a(code=code, n=up)
+ TYPE is (INTEGER(I1P))
+ CALL b64_decode_I1_a(code=code, n=up)
+ TYPE is (CHARACTER(*))
+ CALL b64_decode_string_a(code=code, s=up)
+ END SELECT
+END SUBROUTINE b64_decode_up_a
+
+PURE SUBROUTINE b64_encode_R16(n, code)
+ !< Encode scalar number to base64 (R16P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=134.231_R16P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> CKwcWmTHYEA= <<<
+ REAL(R16P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYR16P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYR16P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
#if defined _R16P
- padd = mod((BYR16P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd
+ padd = MOD((BYR16P), 3_I2P); IF (padd > 0_I4P) padd = 3_I4P - padd
#else
- padd = mod((BYR16P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd
+ padd = MOD((BYR16P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd
#endif
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_R16
-
- pure subroutine b64_encode_R8(n, code)
- !< Encode scalar number to base64 (R8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=1._R8P, code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAAAA8D8= <<<
- real(R8P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYR8P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYR8P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((BYR8P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_R8
-
- pure subroutine b64_encode_R4(n, code)
- !< Encode scalar number to base64 (R4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=0._R4P, code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAA== <<<
- real(R4P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYR4P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYR4P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((BYR4P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_R4
-
- pure subroutine b64_encode_I8(n, code)
- !< Encode scalar number to base64 (I8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=23_I8P, code=code64)
- !< print "(A)", code64
- !<```
- !=> FwAAAAAAAAA= <<<
- integer(I8P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYI8P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYI8P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I8
-
- pure subroutine b64_encode_I4(n, code)
- !< Encode scalar number to base64 (I4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=2023_I4P, code=code64)
- !< print "(A)", code64
- !<```
- !=> 5wcAAA== <<<
- integer(I4P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYI4P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYI4P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((BYI4P),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I4
-
- pure subroutine b64_encode_I2(n, code)
- !< Encode scalar number to base64 (I2P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=-203_I2P, code=code64)
- !< print "(A)", code64
- !<```
- !=> Nf8= <<<
- integer(I2P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYI2P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYI2P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((BYI2P),3_I2P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I2
-
- pure subroutine b64_encode_I1(n, code)
- !< Encode scalar number to base64 (I1P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=120_I1P, code=code64)
- !< print "(A)", code64
- !<```
- !=> eA== <<<
- integer(I1P), intent(in) :: n !< Number to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
-
- allocate(nI1P(1:((BYI1P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYI1P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((BYI1P),3_I1P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I1
-
- pure subroutine b64_encode_string(s, code)
- !< Encode scalar string to base64.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(s='hello', code=code64)
- !< print "(A)", code64
- !<```
- !=> aGVsbG8= <<<
- character(*), intent(in) :: s !< String to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I4P) :: BYCHS !< Bytes of character string.
-
- BYCHS = byte_size(s)
- allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYCHS+2)/3)*4)
- nI1P = transfer(s,nI1P)
- padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_string
-
- pure subroutine b64_encode_R16_a(n, code)
- !< Encode array numbers to base64 (R16P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[121._R16P,2.32_R16P], code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAABAXkCPwvUoXI8CQA== <<<
- real(R16P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYR16P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYR16P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYR16P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_R16_a
-
- pure subroutine b64_encode_R8_a(n, code)
- !< Encode array numbers to base64 (R8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[1._R8P,2._R8P], code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAAAA8D8AAAAAAAAAQA== <<<
- real(R8P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYR8P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYR8P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYR8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_R8_a
-
- pure subroutine b64_encode_R4_a(n, code)
- !< Encode array numbers to base64 (R4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[0._R4P,-32.12_R4P], code=code64)
- !< print "(A)", code64
- !<```
- !=> AAAAAOF6AMI= <<<
- real(R4P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYR4P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYR4P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYR4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_R4_a
-
- pure subroutine b64_encode_I8_a(n, code)
- !< Encode array numbers to base64 (I8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[23_I8P,324_I8P,25456656_I8P,2_I8P], code=code64)
- !< print "(A)", code64
- !<```
- !=> FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA= <<<
- integer(I8P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYI8P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYI8P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYI8P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I8_a
-
- pure subroutine b64_encode_I4_a(n, code)
- !< Encode array numbers to base64 (I4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[2023_I4P,-24_I4P], code=code64)
- !< print "(A)", code64
- !<```
- !=> 5wcAAOj///8= <<<
- integer(I4P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYI4P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYI4P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYI4P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I4_a
-
- pure subroutine b64_encode_I2_a(n, code)
- !< Encode array numbers to base64 (I2P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[-203_I2P,-10_I2P], code=code64)
- !< print "(A)", code64
- !<```
- !=> Nf/2/w== <<<
- integer(I2P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYI2P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYI2P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYI2P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I2_a
-
- pure subroutine b64_encode_I1_a(n, code)
- !< Encode array numbers to base64 (I1P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(n=[120_I1P,-1_I1P], code=code64)
- !< print "(A)", code64
- !<```
- !=> eP8= <<<
- integer(I1P), intent(in) :: n(1:) !< Array of numbers to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded array.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I8P) :: ns !< Size of n.
-
- ns = size(n,dim=1)
- allocate(nI1P(1:((ns*BYI1P+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((ns*BYI1P+2)/3)*4)
- nI1P = transfer(n,nI1P)
- padd = mod((ns*BYI1P),3_I8P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_I1_a
-
- pure subroutine b64_encode_string_a(s, code)
- !< Encode array string to base64.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(len=:), allocatable :: code64
- !< call b64_encode(s=['hello','world'], code=code64)
- !< print "(A)", code64
- !<```
- !=> aGVsbG93b3JsZA== <<<
- character(*), intent(in) :: s(1:) !< String to be encoded.
- character(len=:), allocatable, intent(out) :: code !< Encoded scalar.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
- integer(I4P) :: padd !< Number of padding characters ('=').
- integer(I4P) :: BYCHS !< Bytes of character string.
-
- BYCHS = byte_size(s(1))*size(s,dim=1)
- allocate(nI1P(1:((BYCHS+2)/3)*3)) ; nI1P = 0_I1P
- code = repeat(' ',((BYCHS+2)/3)*4)
- nI1P = transfer(s,nI1P)
- padd = mod((BYCHS),3_I4P) ; if (padd>0_I4P) padd = 3_I4P - padd
- call encode_bits(bits=nI1P,padd=padd,code=code)
- endsubroutine b64_encode_string_a
-
- elemental subroutine b64_decode_R16(code, n)
- !< Decode a base64 code into a scalar number (R16P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R16P) :: scalar_R16
- !< call b64_decode(code='CKwcWmTHYEA=',n=scalar_R16)
- !< print "(L1)", scalar_R16==134.231_R16P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- real(R16P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYR16P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_R16
-
- elemental subroutine b64_decode_R8(code, n)
- !< Decode a base64 code into a scalar number (R8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: scalar_R8
- !< call b64_decode(code='AAAAAAAA8D8=',n=scalar_R8)
- !< print "(L1)", scalar_R8==1._R8P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- real(R8P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYR8P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_R8
-
- elemental subroutine b64_decode_R4(code, n)
- !< Decode a base64 code into a scalar number (R4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: scalar_R4
- !< call b64_decode(code='AAAAAA==',n=scalar_R4)
- !< print "(L1)", scalar_R4==0._R4P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- real(R4P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYR4P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_R4
-
- elemental subroutine b64_decode_I8(code, n)
- !< Decode a base64 code into a scalar number (I8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: scalar_I8
- !< call b64_decode(code='FwAAAAAAAAA=',n=scalar_I8)
- !< print "(L1)", scalar_I8==23_I8P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- integer(I8P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYI8P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I8
-
- elemental subroutine b64_decode_I4(code, n)
- !< Decode a base64 code into a scalar number (I4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: scalar_I4
- !< call b64_decode(code='5wcAAA==',n=scalar_I4)
- !< print "(L1)", scalar_I4==2023_I4P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- integer(I4P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYI4P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I4
-
- elemental subroutine b64_decode_I2(code, n)
- !< Decode a base64 code into a scalar number (I2P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: scalar_I2
- !< call b64_decode(code='Nf8=',n=scalar_I2)
- !< print "(L1)", scalar_I2==-203_I2P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- integer(I2P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYI2P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I2
-
- elemental subroutine b64_decode_I1(code, n)
- !< Decode a base64 code into a scalar number (I1P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: scalar_I1
- !< call b64_decode(code='eA==',n=scalar_I1)
- !< print "(L1)", scalar_I1==120_I1P
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- integer(I1P), intent(out) :: n !< Number to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:BYI1P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I1
-
- elemental subroutine b64_decode_string(code, s)
- !< Decode a base64 code into a scalar string.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(:), allocatable :: code64
- !< code64 = repeat(' ',5)
- !< call b64_decode(code='aGVsbG8=',s=code64)
- !< print "(L1)", code64=='hello'
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- character(*), intent(out) :: s !< String to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:byte_size(s))) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- s = transfer(nI1P,s)
- endsubroutine b64_decode_string
-
- pure subroutine b64_decode_R16_a(code, n)
- !< Decode a base64 code into an array numbers (R16P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R16P) :: array_R16(1:2)
- !< call b64_decode(code='AAAAAABAXkCPwvUoXI8CQA==',n=array_R16)
- !< print "(L1)", str(n=array_R16)==str(n=[121._R16P,2.32_R16P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- real(R16P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYR16P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_R16_a
-
- pure subroutine b64_decode_R8_a(code, n)
- !< Decode a base64 code into an array numbers (R8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: array_R8(1:2)
- !< call b64_decode(code='AAAAAAAA8D8AAAAAAAAAQA==',n=array_R8)
- !< print "(L1)", str(n=array_R8)==str(n=[1._R8P,2._R8P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- real(R8P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYR8P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_R8_a
-
- pure subroutine b64_decode_R4_a(code, n)
- !< Decode a base64 code into an array numbers (R4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: array_R4(1:2)
- !< call b64_decode(code='AAAAAOF6AMI=',n=array_R4)
- !< print "(L1)", str(n=array_R4)==str(n=[0._R4P,-32.12_R4P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- real(R4P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYR4P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_R4_a
-
- pure subroutine b64_decode_I8_a(code, n)
- !< Decode a base64 code into an array numbers (I8P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: array_I8(1:4)
- !< call b64_decode(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=',n=array_I8)
- !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- integer(I8P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYI8P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I8_a
-
- pure subroutine b64_decode_I4_a(code, n)
- !< Decode a base64 code into an array numbers (I4P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: array_I4(1:2)
- !< call b64_decode(code='5wcAAOj///8=',n=array_I4)
- !< print "(L1)", str(n=array_I4)==str(n=[2023_I4P,-24_I4P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- integer(I4P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYI4P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I4_a
-
- pure subroutine b64_decode_I2_a(code, n)
- !< Decode a base64 code into an array numbers (I2P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: array_I2(1:2)
- !< call b64_decode(code='Nf/2/w==',n=array_I2)
- !< print "(L1)", str(n=array_I2)==str(n=[-203_I2P,-10_I2P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- integer(I2P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYI2P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I2_a
-
- pure subroutine b64_decode_I1_a(code, n)
- !< Decode a base64 code into an array numbers (I1P).
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: array_I1(1:2)
- !< call b64_decode(code='eP8=',n=array_I1)
- !< print "(L1)", str(n=array_I1)==str(n=[120_I1P,-1_I1P])
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded array.
- integer(I1P), intent(out) :: n(1:) !< Array of numbers to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:size(n,dim=1)*BYI1P)) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- n = transfer(nI1P,n)
- endsubroutine b64_decode_I1_a
-
- pure subroutine b64_decode_string_a(code, s)
- !< Decode a base64 code into an array of strings.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< character(5) :: array_s(1:2)
- !< call b64_decode(code='aGVsbG93b3JsZA==',s=array_s)
- !< print "(L1)", array_s(1)//array_s(2)=='helloworld'
- !<```
- !=> T <<<
- character(*), intent(in) :: code !< Encoded scalar.
- character(*), intent(out) :: s(1:) !< String to be decoded.
- integer(I1P), allocatable :: nI1P(:) !< One byte integer array containing n.
-
- allocate(nI1P(1:byte_size(s(1))*size(s,dim=1))) ; nI1P = 0_I1P
- call decode_bits(code=code,bits=nI1P)
- s = transfer(nI1P,s)
- endsubroutine b64_decode_string_a
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_R16
+
+PURE SUBROUTINE b64_encode_R8(n, code)
+ !< Encode scalar number to base64 (R8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=1._R8P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAAAA8D8= <<<
+ REAL(R8P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYR8P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYR8P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((BYR8P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_R8
+
+PURE SUBROUTINE b64_encode_R4(n, code)
+ !< Encode scalar number to base64 (R4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=0._R4P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAA== <<<
+ REAL(R4P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYR4P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYR4P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((BYR4P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_R4
+
+PURE SUBROUTINE b64_encode_I8(n, code)
+ !< Encode scalar number to base64 (I8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=23_I8P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> FwAAAAAAAAA= <<<
+ INTEGER(I8P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYI8P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYI8P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((BYI8P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I8
+
+PURE SUBROUTINE b64_encode_I4(n, code)
+ !< Encode scalar number to base64 (I4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=2023_I4P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> 5wcAAA== <<<
+ INTEGER(I4P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYI4P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYI4P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((BYI4P), 3_I4P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I4
+
+PURE SUBROUTINE b64_encode_I2(n, code)
+ !< Encode scalar number to base64 (I2P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=-203_I2P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> Nf8= <<<
+ INTEGER(I2P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYI2P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYI2P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((BYI2P), 3_I2P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I2
+
+PURE SUBROUTINE b64_encode_I1(n, code)
+ !< Encode scalar number to base64 (I1P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=120_I1P, code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> eA== <<<
+ INTEGER(I1P), INTENT(in) :: n !< Number to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+
+ ALLOCATE (nI1P(1:((BYI1P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYI1P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((BYI1P), 3_I1P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I1
+
+PURE SUBROUTINE b64_encode_string(s, code)
+ !< Encode scalar string to base64.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(s='hello', code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> aGVsbG8= <<<
+ CHARACTER(*), INTENT(in) :: s !< String to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I4P) :: BYCHS !< Bytes of character string.
+
+ BYCHS = byte_size(s)
+ ALLOCATE (nI1P(1:((BYCHS + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYCHS + 2) / 3) * 4)
+ nI1P = TRANSFER(s, nI1P)
+ padd = MOD((BYCHS), 3_I4P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_string
+
+PURE SUBROUTINE b64_encode_R16_a(n, code)
+ !< Encode array numbers to base64 (R16P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[121._R16P,2.32_R16P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAABAXkCPwvUoXI8CQA== <<<
+ REAL(R16P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYR16P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYR16P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYR16P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_R16_a
+
+PURE SUBROUTINE b64_encode_R8_a(n, code)
+ !< Encode array numbers to base64 (R8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[1._R8P,2._R8P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAAAA8D8AAAAAAAAAQA== <<<
+ REAL(R8P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYR8P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYR8P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYR8P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_R8_a
+
+PURE SUBROUTINE b64_encode_R4_a(n, code)
+ !< Encode array numbers to base64 (R4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[0._R4P,-32.12_R4P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> AAAAAOF6AMI= <<<
+ REAL(R4P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYR4P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYR4P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYR4P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_R4_a
+
+PURE SUBROUTINE b64_encode_I8_a(n, code)
+ !< Encode array numbers to base64 (I8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[23_I8P,324_I8P,25456656_I8P,2_I8P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA= <<<
+ INTEGER(I8P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYI8P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYI8P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYI8P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I8_a
+
+PURE SUBROUTINE b64_encode_I4_a(n, code)
+ !< Encode array numbers to base64 (I4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[2023_I4P,-24_I4P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> 5wcAAOj///8= <<<
+ INTEGER(I4P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYI4P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYI4P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYI4P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I4_a
+
+PURE SUBROUTINE b64_encode_I2_a(n, code)
+ !< Encode array numbers to base64 (I2P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[-203_I2P,-10_I2P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> Nf/2/w== <<<
+ INTEGER(I2P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYI2P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYI2P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYI2P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I2_a
+
+PURE SUBROUTINE b64_encode_I1_a(n, code)
+ !< Encode array numbers to base64 (I1P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(n=[120_I1P,-1_I1P], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> eP8= <<<
+ INTEGER(I1P), INTENT(in) :: n(1:) !< Array of numbers to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded array.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I8P) :: ns !< Size of n.
+
+ ns = SIZE(n, dim=1)
+ ALLOCATE (nI1P(1:((ns * BYI1P + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((ns * BYI1P + 2) / 3) * 4)
+ nI1P = TRANSFER(n, nI1P)
+ padd = MOD((ns * BYI1P), 3_I8P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_I1_a
+
+PURE SUBROUTINE b64_encode_string_a(s, code)
+ !< Encode array string to base64.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(len=:), allocatable :: code64
+ !< call b64_encode(s=['hello','world'], code=code64)
+ !< print "(A)", code64
+ !<```
+ !=> aGVsbG93b3JsZA== <<<
+ CHARACTER(*), INTENT(in) :: s(1:) !< String to be encoded.
+ CHARACTER(len=:), ALLOCATABLE, INTENT(out) :: code !< Encoded scalar.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+ INTEGER(I4P) :: padd !< Number of padding characters ('=').
+ INTEGER(I4P) :: BYCHS !< Bytes of character string.
+
+ BYCHS = byte_size(s(1)) * SIZE(s, dim=1)
+ ALLOCATE (nI1P(1:((BYCHS + 2) / 3) * 3)); nI1P = 0_I1P
+ code = REPEAT(' ', ((BYCHS + 2) / 3) * 4)
+ nI1P = TRANSFER(s, nI1P)
+ padd = MOD((BYCHS), 3_I4P); IF (padd > 0_I4P) padd = 3_I4P - padd
+ CALL encode_bits(bits=nI1P, padd=padd, code=code)
+END SUBROUTINE b64_encode_string_a
+
+ELEMENTAL SUBROUTINE b64_decode_R16(code, n)
+ !< Decode a base64 code into a scalar number (R16P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R16P) :: scalar_R16
+ !< call b64_decode(code='CKwcWmTHYEA=',n=scalar_R16)
+ !< print "(L1)", scalar_R16==134.231_R16P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ REAL(R16P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYR16P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_R16
+
+ELEMENTAL SUBROUTINE b64_decode_R8(code, n)
+ !< Decode a base64 code into a scalar number (R8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: scalar_R8
+ !< call b64_decode(code='AAAAAAAA8D8=',n=scalar_R8)
+ !< print "(L1)", scalar_R8==1._R8P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ REAL(R8P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYR8P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_R8
+
+ELEMENTAL SUBROUTINE b64_decode_R4(code, n)
+ !< Decode a base64 code into a scalar number (R4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: scalar_R4
+ !< call b64_decode(code='AAAAAA==',n=scalar_R4)
+ !< print "(L1)", scalar_R4==0._R4P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ REAL(R4P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYR4P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_R4
+
+ELEMENTAL SUBROUTINE b64_decode_I8(code, n)
+ !< Decode a base64 code into a scalar number (I8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: scalar_I8
+ !< call b64_decode(code='FwAAAAAAAAA=',n=scalar_I8)
+ !< print "(L1)", scalar_I8==23_I8P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ INTEGER(I8P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYI8P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I8
+
+ELEMENTAL SUBROUTINE b64_decode_I4(code, n)
+ !< Decode a base64 code into a scalar number (I4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: scalar_I4
+ !< call b64_decode(code='5wcAAA==',n=scalar_I4)
+ !< print "(L1)", scalar_I4==2023_I4P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ INTEGER(I4P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYI4P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I4
+
+ELEMENTAL SUBROUTINE b64_decode_I2(code, n)
+ !< Decode a base64 code into a scalar number (I2P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: scalar_I2
+ !< call b64_decode(code='Nf8=',n=scalar_I2)
+ !< print "(L1)", scalar_I2==-203_I2P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ INTEGER(I2P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYI2P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I2
+
+ELEMENTAL SUBROUTINE b64_decode_I1(code, n)
+ !< Decode a base64 code into a scalar number (I1P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: scalar_I1
+ !< call b64_decode(code='eA==',n=scalar_I1)
+ !< print "(L1)", scalar_I1==120_I1P
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ INTEGER(I1P), INTENT(out) :: n !< Number to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:BYI1P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I1
+
+ELEMENTAL SUBROUTINE b64_decode_string(code, s)
+ !< Decode a base64 code into a scalar string.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(:), allocatable :: code64
+ !< code64 = repeat(' ',5)
+ !< call b64_decode(code='aGVsbG8=',s=code64)
+ !< print "(L1)", code64=='hello'
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ CHARACTER(*), INTENT(out) :: s !< String to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:byte_size(s))); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ s = TRANSFER(nI1P, s)
+END SUBROUTINE b64_decode_string
+
+PURE SUBROUTINE b64_decode_R16_a(code, n)
+ !< Decode a base64 code into an array numbers (R16P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R16P) :: array_R16(1:2)
+ !< call b64_decode(code='AAAAAABAXkCPwvUoXI8CQA==',n=array_R16)
+ !< print "(L1)", str(n=array_R16)==str(n=[121._R16P,2.32_R16P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ REAL(R16P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYR16P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_R16_a
+
+PURE SUBROUTINE b64_decode_R8_a(code, n)
+ !< Decode a base64 code into an array numbers (R8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: array_R8(1:2)
+ !< call b64_decode(code='AAAAAAAA8D8AAAAAAAAAQA==',n=array_R8)
+ !< print "(L1)", str(n=array_R8)==str(n=[1._R8P,2._R8P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ REAL(R8P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYR8P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_R8_a
+
+PURE SUBROUTINE b64_decode_R4_a(code, n)
+ !< Decode a base64 code into an array numbers (R4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: array_R4(1:2)
+ !< call b64_decode(code='AAAAAOF6AMI=',n=array_R4)
+ !< print "(L1)", str(n=array_R4)==str(n=[0._R4P,-32.12_R4P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ REAL(R4P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYR4P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_R4_a
+
+PURE SUBROUTINE b64_decode_I8_a(code, n)
+ !< Decode a base64 code into an array numbers (I8P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: array_I8(1:4)
+ !< call b64_decode(code='FwAAAAAAAABEAQAAAAAAABBwhAEAAAAAAgAAAAAAAAA=',n=array_I8)
+ !< print "(L1)", str(n=array_I8)==str(n=[23_I8P,324_I8P,25456656_I8P,2_I8P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ INTEGER(I8P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI8P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I8_a
+
+PURE SUBROUTINE b64_decode_I4_a(code, n)
+ !< Decode a base64 code into an array numbers (I4P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: array_I4(1:2)
+ !< call b64_decode(code='5wcAAOj///8=',n=array_I4)
+ !< print "(L1)", str(n=array_I4)==str(n=[2023_I4P,-24_I4P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ INTEGER(I4P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI4P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I4_a
+
+PURE SUBROUTINE b64_decode_I2_a(code, n)
+ !< Decode a base64 code into an array numbers (I2P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: array_I2(1:2)
+ !< call b64_decode(code='Nf/2/w==',n=array_I2)
+ !< print "(L1)", str(n=array_I2)==str(n=[-203_I2P,-10_I2P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ INTEGER(I2P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI2P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I2_a
+
+PURE SUBROUTINE b64_decode_I1_a(code, n)
+ !< Decode a base64 code into an array numbers (I1P).
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: array_I1(1:2)
+ !< call b64_decode(code='eP8=',n=array_I1)
+ !< print "(L1)", str(n=array_I1)==str(n=[120_I1P,-1_I1P])
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded array.
+ INTEGER(I1P), INTENT(out) :: n(1:) !< Array of numbers to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:SIZE(n, dim=1) * BYI1P)); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ n = TRANSFER(nI1P, n)
+END SUBROUTINE b64_decode_I1_a
+
+PURE SUBROUTINE b64_decode_string_a(code, s)
+ !< Decode a base64 code into an array of strings.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< character(5) :: array_s(1:2)
+ !< call b64_decode(code='aGVsbG93b3JsZA==',s=array_s)
+ !< print "(L1)", array_s(1)//array_s(2)=='helloworld'
+ !<```
+ !=> T <<<
+ CHARACTER(*), INTENT(in) :: code !< Encoded scalar.
+ CHARACTER(*), INTENT(out) :: s(1:) !< String to be decoded.
+ INTEGER(I1P), ALLOCATABLE :: nI1P(:) !< One byte integer array containing n.
+
+ ALLOCATE (nI1P(1:byte_size(s(1)) * SIZE(s, dim=1))); nI1P = 0_I1P
+ CALL decode_bits(code=code, bits=nI1P)
+ s = TRANSFER(nI1P, s)
+END SUBROUTINE b64_decode_string_a
endmodule befor64
diff --git a/src/modules/BeFoR64/src/befor64_pack_data_m.F90 b/src/modules/BeFoR64/src/befor64_pack_data_m.F90
index 29fddacf8..aa0dd389b 100644
--- a/src/modules/BeFoR64/src/befor64_pack_data_m.F90
+++ b/src/modules/BeFoR64/src/befor64_pack_data_m.F90
@@ -1,14 +1,14 @@
!< KISS library for packing heterogeneous data into single (homogeneous) packed one.
!
-module befor64_pack_data_m
+MODULE befor64_pack_data_m
!< KISS library for packing heterogeneous data into single (homogeneous) packed one.
-use penf
+USE penf
-implicit none
-private
-public :: pack_data
+IMPLICIT NONE
+PRIVATE
+PUBLIC :: pack_data
-interface pack_data
+INTERFACE pack_data
!< Pack different kinds of data into single I1P array.
!<
!< This is useful for encoding different (heterogeneous) kinds variables into a single (homogeneous) stream of bits.
@@ -63,786 +63,786 @@ module befor64_pack_data_m
pack_data_I4_R8, pack_data_I4_R4, pack_data_I4_I8, pack_data_I4_I2, pack_data_I4_I1, &
pack_data_I2_R8, pack_data_I2_R4, pack_data_I2_I8, pack_data_I2_I4, pack_data_I2_I1, &
pack_data_I1_R8, pack_data_I1_R4, pack_data_I1_I8, pack_data_I1_I4, pack_data_I1_I2
-endinterface
-
-contains
- pure subroutine pack_data_R8_R4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: a1(1)
- !< real(R4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- real(R8P), intent(in) :: a1(1:) !< Firs data stream.
- real(R4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R8_R4
-
- pure subroutine pack_data_R8_I8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: a1(1)
- !< integer(I8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- real(R8P), intent(in) :: a1(1:) !< First data stream.
- integer(I8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R8_I8
-
- pure subroutine pack_data_R8_I4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: a1(1)
- !< integer(I4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- real(R8P), intent(in) :: a1(1:) !< First data stream.
- integer(I4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R8_I4
-
- pure subroutine pack_data_R8_I2(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: a1(1)
- !< integer(I2P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- real(R8P), intent(in) :: a1(1:) !< First data stream.
- integer(I2P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R8_I2
-
- pure subroutine pack_data_R8_I1(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R8P) :: a1(1)
- !< integer(I1P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- real(R8P), intent(in) :: a1(1:) !< First data stream.
- integer(I1P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R8_I1
-
- pure subroutine pack_data_R4_R8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: a1(1)
- !< real(R8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- real(R4P), intent(in) :: a1(1:) !< Firs data stream.
- real(R8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R4_R8
-
- pure subroutine pack_data_R4_I8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: a1(1)
- !< integer(I8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- real(R4P), intent(in) :: a1(1:) !< First data stream.
- integer(I8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R4_I8
-
- pure subroutine pack_data_R4_I4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: a1(1)
- !< integer(I4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- real(R4P), intent(in) :: a1(1:) !< First data stream.
- integer(I4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R4_I4
-
- pure subroutine pack_data_R4_I2(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: a1(1)
- !< integer(I2P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- real(R4P), intent(in) :: a1(1:) !< First data stream.
- integer(I2P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R4_I2
-
- pure subroutine pack_data_R4_I1(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< real(R4P) :: a1(1)
- !< integer(I1P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- real(R4P), intent(in) :: a1(1:) !< First data stream.
- integer(I1P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_R4_I1
-
- pure subroutine pack_data_I8_R8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: a1(1)
- !< real(R8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I8P), intent(in) :: a1(1:) !< First data stream.
- real(R8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I8_R8
-
- pure subroutine pack_data_I8_R4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: a1(1)
- !< real(R4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I8P), intent(in) :: a1(1:) !< First data stream.
- real(R4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I8_R4
-
- pure subroutine pack_data_I8_I4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: a1(1)
- !< integer(I4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- integer(I8P), intent(in) :: a1(1:) !< First data stream.
- integer(I4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I8_I4
-
- pure subroutine pack_data_I8_I2(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: a1(1)
- !< integer(I2P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- integer(I8P), intent(in) :: a1(1:) !< First data stream.
- integer(I2P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I8_I2
-
- pure subroutine pack_data_I8_I1(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I8P) :: a1(1)
- !< integer(I1P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(9)
- !<```
- !=> 1 <<<
- integer(I8P), intent(in) :: a1(1:) !< First data stream.
- integer(I1P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I8_I1
-
- pure subroutine pack_data_I4_R8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: a1(1)
- !< real(R8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I4P), intent(in) :: a1(1:) !< First data stream.
- real(R8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I4_R8
-
- pure subroutine pack_data_I4_R4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: a1(1)
- !< real(R4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I4P), intent(in) :: a1(1:) !< First data stream.
- real(R4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I4_R4
-
- pure subroutine pack_data_I4_I8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: a1(1)
- !< integer(I8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- integer(I4P), intent(in) :: a1(1:) !< First data stream.
- integer(I8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I4_I8
-
- pure subroutine pack_data_I4_I2(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: a1(1)
- !< integer(I2P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- integer(I4P), intent(in) :: a1(1:) !< First data stream.
- integer(I2P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I4_I2
-
- pure subroutine pack_data_I4_I1(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I4P) :: a1(1)
- !< integer(I1P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(5)
- !<```
- !=> 1 <<<
- integer(I4P), intent(in) :: a1(1:) !< First data stream.
- integer(I1P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I4_I1
-
- pure subroutine pack_data_I2_R8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: a1(1)
- !< real(R8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I2P), intent(in) :: a1(1:) !< First data stream.
- real(R8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I2_R8
-
- pure subroutine pack_data_I2_R4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: a1(1)
- !< real(R4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I2P), intent(in) :: a1(1:) !< First data stream.
- real(R4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I2_R4
-
- pure subroutine pack_data_I2_I8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: a1(1)
- !< integer(I8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(3)
- !<```
- !=> 1 <<<
- integer(I2P), intent(in) :: a1(1:) !< First data stream.
- integer(I8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I2_I8
-
- pure subroutine pack_data_I2_I4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: a1(1)
- !< integer(I4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(3)
- !<```
- !=> 1 <<<
- integer(I2P), intent(in) :: a1(1:) !< First data stream.
- integer(I4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I2_I4
-
- pure subroutine pack_data_I2_I1(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I2P) :: a1(1)
- !< integer(I1P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(3)
- !<```
- !=> 1 <<<
- integer(I2P), intent(in) :: a1(1:) !< First data stream.
- integer(I1P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I2_I1
-
- pure subroutine pack_data_I1_R8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: a1(1)
- !< real(R8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I1P), intent(in) :: a1(1:) !< First data stream.
- real(R8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I1_R8
-
- pure subroutine pack_data_I1_R4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: a1(1)
- !< real(R4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(size(pack, dim=1))
- !<```
- !=> 63 <<<
- integer(I1P), intent(in) :: a1(1:) !< First data stream.
- real(R4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I1_R4
-
- pure subroutine pack_data_I1_I8(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: a1(1)
- !< integer(I8P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(2)
- !<```
- !=> 1 <<<
- integer(I1P), intent(in) :: a1(1:) !< First data stream.
- integer(I8P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I1_I8
-
- pure subroutine pack_data_I1_I4(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: a1(1)
- !< integer(I4P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(2)
- !<```
- !=> 1 <<<
- integer(I1P), intent(in) :: a1(1:) !< First data stream.
- integer(I4P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I1_I4
-
- pure subroutine pack_data_I1_I2(a1, a2, packed)
- !< Pack different kinds of data into single I1P array.
- !<
- !<```fortran
- !< use befor64
- !< use penf
- !< integer(I1P) :: a1(1)
- !< integer(I2P) :: a2(1)
- !< integer(I1P), allocatable :: pack(:)
- !< a1(1) = 0
- !< a2(1) = 1
- !< call pack_data(a1=a1, a2=a2, packed=pack)
- !< print *, pack(2)
- !<```
- !=> 1 <<<
- integer(I1P), intent(in) :: a1(1:) !< First data stream.
- integer(I2P), intent(in) :: a2(1:) !< Second data stream.
- integer(I1P), allocatable, intent(inout) :: packed(:) !< Packed data into I1P array.
- integer(I1P), allocatable :: p1(:) !< Temporary packed data of first stream.
- integer(I1P), allocatable :: p2(:) !< Temporary packed data of second stream.
-
- p1 = transfer(a1,p1)
- p2 = transfer(a2,p2)
- packed = [p1,p2]
- endsubroutine pack_data_I1_I2
+end interface
+
+CONTAINS
+PURE SUBROUTINE pack_data_R8_R4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: a1(1)
+ !< real(R4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ REAL(R8P), INTENT(in) :: a1(1:) !< Firs data stream.
+ REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R8_R4
+
+PURE SUBROUTINE pack_data_R8_I8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: a1(1)
+ !< integer(I8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ REAL(R8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R8_I8
+
+PURE SUBROUTINE pack_data_R8_I4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: a1(1)
+ !< integer(I4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ REAL(R8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R8_I4
+
+PURE SUBROUTINE pack_data_R8_I2(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: a1(1)
+ !< integer(I2P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ REAL(R8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R8_I2
+
+PURE SUBROUTINE pack_data_R8_I1(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R8P) :: a1(1)
+ !< integer(I1P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ REAL(R8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R8_I1
+
+PURE SUBROUTINE pack_data_R4_R8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: a1(1)
+ !< real(R8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ REAL(R4P), INTENT(in) :: a1(1:) !< Firs data stream.
+ REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R4_R8
+
+PURE SUBROUTINE pack_data_R4_I8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: a1(1)
+ !< integer(I8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ REAL(R4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R4_I8
+
+PURE SUBROUTINE pack_data_R4_I4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: a1(1)
+ !< integer(I4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ REAL(R4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R4_I4
+
+PURE SUBROUTINE pack_data_R4_I2(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: a1(1)
+ !< integer(I2P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ REAL(R4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R4_I2
+
+PURE SUBROUTINE pack_data_R4_I1(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< real(R4P) :: a1(1)
+ !< integer(I1P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ REAL(R4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_R4_I1
+
+PURE SUBROUTINE pack_data_I8_R8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: a1(1)
+ !< real(R8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I8_R8
+
+PURE SUBROUTINE pack_data_I8_R4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: a1(1)
+ !< real(R4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I8_R4
+
+PURE SUBROUTINE pack_data_I8_I4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: a1(1)
+ !< integer(I4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I8_I4
+
+PURE SUBROUTINE pack_data_I8_I2(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: a1(1)
+ !< integer(I2P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I8_I2
+
+PURE SUBROUTINE pack_data_I8_I1(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I8P) :: a1(1)
+ !< integer(I1P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(9)
+ !<```
+ !=> 1 <<<
+ INTEGER(I8P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I8_I1
+
+PURE SUBROUTINE pack_data_I4_R8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: a1(1)
+ !< real(R8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I4_R8
+
+PURE SUBROUTINE pack_data_I4_R4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: a1(1)
+ !< real(R4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I4_R4
+
+PURE SUBROUTINE pack_data_I4_I8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: a1(1)
+ !< integer(I8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I4_I8
+
+PURE SUBROUTINE pack_data_I4_I2(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: a1(1)
+ !< integer(I2P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I4_I2
+
+PURE SUBROUTINE pack_data_I4_I1(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I4P) :: a1(1)
+ !< integer(I1P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(5)
+ !<```
+ !=> 1 <<<
+ INTEGER(I4P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I4_I1
+
+PURE SUBROUTINE pack_data_I2_R8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: a1(1)
+ !< real(R8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I2_R8
+
+PURE SUBROUTINE pack_data_I2_R4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: a1(1)
+ !< real(R4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I2_R4
+
+PURE SUBROUTINE pack_data_I2_I8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: a1(1)
+ !< integer(I8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(3)
+ !<```
+ !=> 1 <<<
+ INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I2_I8
+
+PURE SUBROUTINE pack_data_I2_I4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: a1(1)
+ !< integer(I4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(3)
+ !<```
+ !=> 1 <<<
+ INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I2_I4
+
+PURE SUBROUTINE pack_data_I2_I1(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I2P) :: a1(1)
+ !< integer(I1P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(3)
+ !<```
+ !=> 1 <<<
+ INTEGER(I2P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I1P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I2_I1
+
+PURE SUBROUTINE pack_data_I1_R8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: a1(1)
+ !< real(R8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I1_R8
+
+PURE SUBROUTINE pack_data_I1_R4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: a1(1)
+ !< real(R4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(size(pack, dim=1))
+ !<```
+ !=> 63 <<<
+ INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream.
+ REAL(R4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I1_R4
+
+PURE SUBROUTINE pack_data_I1_I8(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: a1(1)
+ !< integer(I8P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(2)
+ !<```
+ !=> 1 <<<
+ INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I8P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I1_I8
+
+PURE SUBROUTINE pack_data_I1_I4(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: a1(1)
+ !< integer(I4P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(2)
+ !<```
+ !=> 1 <<<
+ INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I4P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I1_I4
+
+PURE SUBROUTINE pack_data_I1_I2(a1, a2, packed)
+ !< Pack different kinds of data into single I1P array.
+ !<
+ !<```fortran
+ !< use befor64
+ !< use penf
+ !< integer(I1P) :: a1(1)
+ !< integer(I2P) :: a2(1)
+ !< integer(I1P), allocatable :: pack(:)
+ !< a1(1) = 0
+ !< a2(1) = 1
+ !< call pack_data(a1=a1, a2=a2, packed=pack)
+ !< print *, pack(2)
+ !<```
+ !=> 1 <<<
+ INTEGER(I1P), INTENT(in) :: a1(1:) !< First data stream.
+ INTEGER(I2P), INTENT(in) :: a2(1:) !< Second data stream.
+ INTEGER(I1P), ALLOCATABLE, INTENT(inout) :: packed(:) !< Packed data into I1P array.
+ INTEGER(I1P), ALLOCATABLE :: p1(:) !< Temporary packed data of first stream.
+ INTEGER(I1P), ALLOCATABLE :: p2(:) !< Temporary packed data of second stream.
+
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+end subroutine pack_data_I1_I2
endmodule befor64_pack_data_m
diff --git a/src/modules/CInterface/src/CInterface.F90 b/src/modules/CInterface/src/CInterface.F90
index ae30ad133..a52bc6332 100644
--- a/src/modules/CInterface/src/CInterface.F90
+++ b/src/modules/CInterface/src/CInterface.F90
@@ -18,8 +18,8 @@ MODULE CInterface
USE GlobalData
USE String_Class, ONLY: String
USE, INTRINSIC :: ISO_C_BINDING, C_PTR => C_PTR, &
- & C_CHAR_PTR => C_PTR, C_CONST_CHAR_PTR => C_PTR, &
- & C_void_ptr => C_PTR, C_CONST_VOID_PTR => C_PTR
+ C_CHAR_PTR => C_PTR, C_CONST_CHAR_PTR => C_PTR, &
+ C_void_ptr => C_PTR, C_CONST_VOID_PTR => C_PTR
IMPLICIT NONE
PRIVATE
diff --git a/src/modules/CMakeLists.txt b/src/modules/CMakeLists.txt
index 18beb64bf..396c467c6 100644
--- a/src/modules/CMakeLists.txt
+++ b/src/modules/CMakeLists.txt
@@ -61,7 +61,7 @@ include(${CMAKE_CURRENT_LIST_DIR}/ARPACK/CMakeLists.txt)
include(${CMAKE_CURRENT_LIST_DIR}/Hashing/CMakeLists.txt)
# Gnuplot
-include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt)
+# include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt)
# CInterface
include(${CMAKE_CURRENT_LIST_DIR}/CInterface/CMakeLists.txt)
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90
index 90411faa2..245733347 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90
@@ -177,7 +177,7 @@ END SUBROUTINE obj_Add5
INTERFACE Add
MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, &
- & ivar, jvar, VALUE, scale)
+ ivar, jvar, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
@@ -247,8 +247,8 @@ END SUBROUTINE obj_Add7
! summary: Adds the specific row and column entry to a given value
INTERFACE Add
- MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, iDOF, jDOF, VALUE, scale)
+ MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, iDOF, jDOF, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
!! row node number
@@ -297,8 +297,8 @@ END SUBROUTINE obj_Add8
!@endnote
INTERFACE Add
- MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale)
+ MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
!! row node number
@@ -339,7 +339,7 @@ END SUBROUTINE obj_Add9
INTERFACE Add
MODULE PURE SUBROUTINE obj_Add10(obj, iNodeNum, jNodeNum, &
- & ivar, jvar, VALUE, scale)
+ ivar, jvar, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
@@ -359,8 +359,8 @@ END SUBROUTINE obj_Add10
! summary: Adds the specific row and column entry to a given value
INTERFACE Add
- MODULE PURE SUBROUTINE obj_Add11(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, iDOF, jDOF, VALUE, scale)
+ MODULE PURE SUBROUTINE obj_Add11(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, iDOF, jDOF, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
!! row node number
@@ -389,8 +389,8 @@ END SUBROUTINE obj_Add11
! summary: Adds the specific row and column entry to a given value
INTERFACE Add
- MODULE PURE SUBROUTINE obj_Add12(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale)
+ MODULE PURE SUBROUTINE obj_Add12(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
!! row node number
@@ -419,17 +419,17 @@ END SUBROUTINE obj_Add12
! summary: Adds the specific row and column entry to a given value
INTERFACE Add
- MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale)
+ MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
!! row node number
INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
!! column node number
INTEGER(I4B), INTENT(IN) :: ivar
- !!
+ !! row variable
INTEGER(I4B), INTENT(IN) :: jvar
- !!
+ !! column variable
INTEGER(I4B), INTENT(IN) :: ispacecompo
INTEGER(I4B), INTENT(IN) :: itimecompo(:)
INTEGER(I4B), INTENT(IN) :: jspacecompo
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90
index ee8c251ca..1b7dc5f2a 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_DBCMethods.F90
@@ -17,7 +17,7 @@
MODULE CSRMatrix_DBCMethods
USE BaseType, ONLY: CSRMatrix_
-USE GlobalData, ONLY: I4B
+USE GlobalData, ONLY: I4B, LGT, DFP
IMPLICIT NONE
PRIVATE
PUBLIC :: ApplyDBC
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90
index 7f7a903ba..1a66b9b33 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90
@@ -39,7 +39,7 @@ MODULE CSRMatrix_GetMethods
PUBLIC :: GetValue
!----------------------------------------------------------------------------
-! GetIA@GetMethods
+! GetIA
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -55,7 +55,7 @@ END FUNCTION obj_GetIA
END INTERFACE GetIA
!----------------------------------------------------------------------------
-! GetJA@GetMethods
+! GetJA
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -111,7 +111,7 @@ END FUNCTION obj_GetSeveralValue
END INTERFACE Get
!----------------------------------------------------------------------------
-! GetStorageFMT@getMethods
+! GetStorageFMT
!----------------------------------------------------------------------------
INTERFACE GetStorageFMT
@@ -127,7 +127,7 @@ END FUNCTION obj_GetStorageFMT
END INTERFACE OPERATOR(.storageFMT.)
!----------------------------------------------------------------------------
-! GetMatrixProp@getMethod
+! GetMatrixProp
!----------------------------------------------------------------------------
INTERFACE GetMatrixProp
@@ -142,7 +142,7 @@ END FUNCTION obj_GetMatrixProp
END INTERFACE OPERATOR(.MatrixProp.)
!----------------------------------------------------------------------------
-! GetDOFPointer@getMethod
+! GetDOFPointer
!----------------------------------------------------------------------------
INTERFACE GetDOFPointer
@@ -154,7 +154,7 @@ END FUNCTION obj_GetDOFPointer
END INTERFACE GetDOFPointer
!----------------------------------------------------------------------------
-! isSquare@GetMethod
+! isSquare
!----------------------------------------------------------------------------
INTERFACE isSquare
@@ -165,7 +165,7 @@ END FUNCTION obj_isSquare
END INTERFACE isSquare
!----------------------------------------------------------------------------
-! isRectangle@GetMethod
+! isRectangle
!----------------------------------------------------------------------------
INTERFACE isRectangle
@@ -176,7 +176,7 @@ END FUNCTION obj_isRectangle
END INTERFACE isRectangle
!----------------------------------------------------------------------------
-! GetColNumber@GetMethods
+! GetColNumber
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -192,7 +192,7 @@ END FUNCTION obj_GetColNumber
END INTERFACE GetColNumber
!----------------------------------------------------------------------------
-! GetColIndex@GetMethods
+! GetColIndex
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -208,7 +208,7 @@ END FUNCTION obj_GetColIndex
END INTERFACE GetColIndex
!----------------------------------------------------------------------------
-! startColumn@GetMethods
+! startColumn
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -224,7 +224,7 @@ END FUNCTION obj_startColumn
END INTERFACE OPERATOR(.startColumn.)
!----------------------------------------------------------------------------
-! endColumn@GetMethods
+! endColumn
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -240,7 +240,7 @@ END FUNCTION obj_endColumn
END INTERFACE OPERATOR(.endColumn.)
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -255,15 +255,16 @@ END FUNCTION obj_endColumn
! - Symbolic we are performing following task `obj(nodenum, nodenum)=value`
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE)
+ MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE, nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
END SUBROUTINE obj_Get0
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -288,17 +289,18 @@ END SUBROUTINE obj_Get0
! - Usually, element matrix is stored with `DOF_FMT`
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE)
+ MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE, nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
INTEGER(I4B), INTENT(IN) :: storageFMT
!! storage format of value (desired format of value)
+ REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
END SUBROUTINE obj_Get1
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -329,8 +331,12 @@ MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE)
END SUBROUTINE obj_Get2
END INTERFACE GetValue
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE)
+ MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE, nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: irow(:)
!! row index
@@ -338,11 +344,12 @@ MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE)
!! column index
REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
!! value
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
END SUBROUTINE obj_Get10
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -372,7 +379,7 @@ END SUBROUTINE obj_Get10
INTERFACE GetValue
MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, iDOF, &
- & jDOF, VALUE)
+ jDOF, VALUE)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
!! row node number
@@ -388,7 +395,7 @@ END SUBROUTINE obj_Get3
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -407,7 +414,7 @@ END SUBROUTINE obj_Get3
INTERFACE GetValue
MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, &
- & ivar, jvar, VALUE)
+ ivar, jvar, VALUE, nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
!! Block csr matrix
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
@@ -420,11 +427,12 @@ MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, &
!! column physical variables
REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
!! value
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
END SUBROUTINE obj_Get4
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -452,8 +460,8 @@ END SUBROUTINE obj_Get4
!@endnote
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, iDOF, jDOF, VALUE)
+ MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, iDOF, jDOF, VALUE)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
!! row node number
@@ -473,7 +481,7 @@ END SUBROUTINE obj_Get5
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -481,8 +489,8 @@ END SUBROUTINE obj_Get5
! summary: Gets the specific row and column entry from a given value
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, iDOF, jDOF, VALUE)
+ MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, iDOF, jDOF, VALUE, nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
!! block matrix field
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
@@ -499,11 +507,12 @@ MODULE PURE SUBROUTINE obj_Get6(obj, iNodeNum, jNodeNum, ivar, &
!! col degree of freedom
REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
!! Matrix value
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
END SUBROUTINE obj_Get6
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -531,8 +540,8 @@ END SUBROUTINE obj_Get6
!@endnote
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE)
+ MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
!! row node number
@@ -556,12 +565,13 @@ END SUBROUTINE obj_Get7
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! GetValue
+! GetValue
!----------------------------------------------------------------------------
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE)
+ MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE, &
+ nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
!! row node number
@@ -581,11 +591,12 @@ MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, &
!! col time component
REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
!! scalar value to be Get
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
END SUBROUTINE obj_Get9
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@GetMethod
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -597,13 +608,10 @@ END SUBROUTINE obj_Get9
! - The number of nodes in obj1 and obj2 should be same
INTERFACE GetValue
- MODULE SUBROUTINE obj_Get8(obj1, obj2, &
- & ivar1, jvar1, &
- & ispacecompo1, jspacecompo1, &
- & itimecompo1, jtimecompo1, &
- & ivar2, jvar2, &
- & ispacecompo2, jspacecompo2, &
- & itimecompo2, jtimecompo2, ierr)
+ MODULE SUBROUTINE obj_Get8(obj1, obj2, ivar1, jvar1, &
+ ispacecompo1, jspacecompo1, itimecompo1, jtimecompo1, &
+ ivar2, jvar2, ispacecompo2, jspacecompo2, itimecompo2, &
+ jtimecompo2, ierr)
TYPE(CSRMatrix_), INTENT(IN) :: obj1
!! master object
TYPE(CSRMatrix_), INTENT(INOUT) :: obj2
@@ -638,7 +646,7 @@ END SUBROUTINE obj_Get8
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@GetMethod
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -650,8 +658,8 @@ END SUBROUTINE obj_Get8
! - The number of nodes in obj1 and obj2 should be same
INTERFACE
- MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, &
- & jdof2, tNodes1, tNodes2)
+ MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, &
+ jdof2, tNodes1, tNodes2)
TYPE(CSRMatrix_), INTENT(IN) :: obj1
!! master object
TYPE(CSRMatrix_), INTENT(INOUT) :: obj2
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90
index 674e73388..2014bc6bb 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_MatVecMethods.F90
@@ -17,7 +17,7 @@
MODULE CSRMatrix_MatVecMethods
USE GlobalData, ONLY: I4B, DFP, LGT
-USE BaseType, ONLY: CSRMatrix_
+USE BaseType, ONLY: CSRMatrix_, RealVector_
IMPLICIT NONE
PRIVATE
@@ -216,7 +216,7 @@ END SUBROUTINE csrMat_AtMatvec
INTERFACE MatVec
MODULE SUBROUTINE csrMat_MatVec1(obj, x, y, isTranspose, addContribution, &
- & scale)
+ scale)
TYPE(CSRMatrix_), INTENT(IN) :: obj
REAL(DFP), INTENT(IN) :: x(:)
REAL(DFP), INTENT(INOUT) :: y(:)
@@ -240,7 +240,7 @@ END SUBROUTINE csrMat_MatVec1
INTERFACE MatVec
MODULE SUBROUTINE csrMat_MatVec2(A, JA, x, y, addContribution, &
- & scale)
+ scale)
REAL(DFP), INTENT(IN) :: A(:)
INTEGER(I4B), INTENT(IN) :: JA(:)
REAL(DFP), INTENT(IN) :: x(:)
@@ -250,6 +250,22 @@ MODULE SUBROUTINE csrMat_MatVec2(A, JA, x, y, addContribution, &
END SUBROUTINE csrMat_MatVec2
END INTERFACE MatVec
+!----------------------------------------------------------------------------
+! Matvec@MatVec
+!----------------------------------------------------------------------------
+
+INTERFACE MatVec
+ MODULE SUBROUTINE csrMat_MatVec3(obj, x, y, isTranspose, addContribution, &
+ scale)
+ TYPE(CSRMatrix_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: x
+ TYPE(RealVector_), INTENT(INOUT) :: y
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isTranspose
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: addContribution
+ REAL(DFP), OPTIONAL, INTENT(IN) :: scale
+ END SUBROUTINE csrMat_MatVec3
+END INTERFACE MatVec
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90 b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90
index 41cf2828c..4c18fd50a 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_Method.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_Method.F90
@@ -16,34 +16,34 @@
!
MODULE CSRMatrix_Method
-USE CSRMatrix_ConstructorMethods
-USE CSRMatrix_IOMethods
-USE CSRMatrix_SparsityMethods
-USE CSRMatrix_SetMethods
USE CSRMatrix_AddMethods
-USE CSRMatrix_SetRowMethods
-USE CSRMatrix_SetColMethods
-USE CSRMatrix_SetBlockRowMethods
-USE CSRMatrix_SetBlockColMethods
+USE CSRMatrix_ConstructorMethods
+USE CSRMatrix_DBCMethods
+USE CSRMatrix_DiagonalScalingMethods
+USE CSRMatrix_GetBlockColMethods
+USE CSRMatrix_GetBlockRowMethods
+USE CSRMatrix_GetColMethods
USE CSRMatrix_GetMethods
USE CSRMatrix_GetRowMethods
-USE CSRMatrix_GetColMethods
USE CSRMatrix_GetSubMatrixMethods
-USE CSRMatrix_GetBlockRowMethods
-USE CSRMatrix_GetBlockColMethods
-USE CSRMatrix_UnaryMethods
USE CSRMatrix_ILUMethods
+USE CSRMatrix_IOMethods
USE CSRMatrix_LUSolveMethods
+USE CSRMatrix_LinSolveMethods
USE CSRMatrix_MatVecMethods
-USE CSRMatrix_SymMatmulMethods
-USE CSRMatrix_ReorderingMethods
-USE CSRMatrix_DiagonalScalingMethods
USE CSRMatrix_MatrixMarketIO
-USE CSRMatrix_Superlu
-USE CSRMatrix_SpectralMethods
+USE CSRMatrix_ReorderingMethods
USE CSRMatrix_SchurMethods
-USE CSRMatrix_DBCMethods
-USE CSRMatrix_LinSolveMethods
+USE CSRMatrix_SetBlockColMethods
+USE CSRMatrix_SetBlockRowMethods
+USE CSRMatrix_SetColMethods
+USE CSRMatrix_SetMethods
+USE CSRMatrix_SetRowMethods
+USE CSRMatrix_SparsityMethods
+USE CSRMatrix_SpectralMethods
+USE CSRMatrix_Superlu
+USE CSRMatrix_SymMatmulMethods
+USE CSRMatrix_UnaryMethods
USE GlobalData, ONLY: I4B
INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_CSR = 0
INTEGER(I4B), PARAMETER, PUBLIC :: SPARSE_FMT_COO = 1
diff --git a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90 b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90
index b38be47e3..367b49e0a 100644
--- a/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90
+++ b/src/modules/ConvectiveMatrix/src/ConvectiveMatrix_Method.F90
@@ -26,6 +26,7 @@ MODULE ConvectiveMatrix_Method
PRIVATE
PUBLIC :: ConvectiveMatrix
+PUBLIC :: ConvectiveMatrix_
!----------------------------------------------------------------------------
! ConvectiveMatrix@ConvectiveMatrixMethods
@@ -36,7 +37,7 @@ MODULE ConvectiveMatrix_Method
! update: 2021-11-21
! summary: returns the convective matrix
-INTERFACE
+INTERFACE ConvectiveMatrix
MODULE PURE FUNCTION ConvectiveMatrix_1(test, trial, term1, &
& term2, opt) RESULT(Ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -45,15 +46,32 @@ MODULE PURE FUNCTION ConvectiveMatrix_1(test, trial, term1, &
!! del_x, del_y, del_z, del_x_all, del_none
INTEGER(I4B), INTENT(IN) :: term2
!! del_x, del_y, del_z, del_x_all, del_none
- INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION ConvectiveMatrix_1
-END INTERFACE
-
-INTERFACE ConvectiveMatrix
- MODULE PROCEDURE ConvectiveMatrix_1
END INTERFACE ConvectiveMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: Convective matrix without allcation
+
+INTERFACE ConvectiveMatrix_
+ MODULE PURE SUBROUTINE ConvectiveMatrix1_(test, trial, term1, &
+ & term2, nrow, ncol, opt, ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(inout) :: ans(:, :)
+ END SUBROUTINE ConvectiveMatrix1_
+END INTERFACE ConvectiveMatrix_
+
!----------------------------------------------------------------------------
! ConvectiveMatrix@ConvectiveMatrixMethods
!----------------------------------------------------------------------------
@@ -63,7 +81,7 @@ END FUNCTION ConvectiveMatrix_1
! update: 2021-11-21
! summary: returns the convective matrix
-INTERFACE
+INTERFACE ConvectiveMatrix
MODULE PURE FUNCTION ConvectiveMatrix_2(test, trial, c, crank, term1, &
& term2, opt) RESULT(Ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -76,16 +94,35 @@ MODULE PURE FUNCTION ConvectiveMatrix_2(test, trial, c, crank, term1, &
!! del_x, del_y, del_z, del_x_all, del_none
INTEGER(I4B), INTENT(IN) :: term2
!! del_x, del_y, del_z, del_x_all, del_none
- INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
!! number of copies
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION ConvectiveMatrix_2
-END INTERFACE
-
-INTERFACE ConvectiveMatrix
- MODULE PROCEDURE ConvectiveMatrix_2
END INTERFACE ConvectiveMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: Convective matrix without allcation
+
+INTERFACE ConvectiveMatrix_
+ MODULE PURE SUBROUTINE ConvectiveMatrix2_(test, trial, c, crank, term1, &
+ & term2, opt, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(inout) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE ConvectiveMatrix2_
+END INTERFACE ConvectiveMatrix_
+
!----------------------------------------------------------------------------
! ConvectiveMatrix@ConvectiveMatrixMethods
!----------------------------------------------------------------------------
@@ -95,7 +132,7 @@ END FUNCTION ConvectiveMatrix_2
! update: 2021-11-21
! summary: returns the convective matrix
-INTERFACE
+INTERFACE ConvectiveMatrix
MODULE PURE FUNCTION ConvectiveMatrix_3(test, trial, c, crank, term1, &
& term2, opt) RESULT(Ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -108,18 +145,37 @@ MODULE PURE FUNCTION ConvectiveMatrix_3(test, trial, c, crank, term1, &
!! del_x, del_y, del_z, del_x_all, del_none
INTEGER(I4B), INTENT(IN) :: term2
!! del_x, del_y, del_z, del_x_all, del_none
- INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
!! number of copies
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION ConvectiveMatrix_3
-END INTERFACE
-
-INTERFACE ConvectiveMatrix
- MODULE PROCEDURE ConvectiveMatrix_3
END INTERFACE ConvectiveMatrix
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: Convective matrix without allcation
+
+INTERFACE ConvectiveMatrix_
+ MODULE PURE SUBROUTINE ConvectiveMatrix3_(test, trial, c, crank, term1, &
+ & term2, opt, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(inout) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE ConvectiveMatrix3_
+END INTERFACE ConvectiveMatrix_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE ConvectiveMatrix_Method
diff --git a/src/modules/DOF/src/DOF_ConstructorMethods.F90 b/src/modules/DOF/src/DOF_ConstructorMethods.F90
index f70e5bd71..d0dec8331 100644
--- a/src/modules/DOF/src/DOF_ConstructorMethods.F90
+++ b/src/modules/DOF/src/DOF_ConstructorMethods.F90
@@ -37,18 +37,18 @@ MODULE DOF_ConstructorMethods
!> author: Vikas Sharma, Ph. D.
! date: 23 Feb 2021
-! summary: This subroutine initiate DOF_ object
+! summary: This subroutine Initiate DOF_ object
!
!# Introduction
!
-! This subroutine initiate DOF_ object
+! This subroutine Initiate DOF_ object
!
!- If the size of all physical variables are equal then set
! tNodes = [tNodes] otherwise we need to provide size of each dof
!- For a scalar physical variable such as pressure and temperature,
! `spacecompo` is set to -1.
!- For a time independent physical variable `timecompo` is set to 1.
-!- The size of `Names`, `spacecompo`, `timecompo` should be same
+!- The size of `names`, `spacecompo`, `timecompo` should be same
!
!@note
! $\matbf{v}$ is a physical variable, however,
@@ -56,21 +56,21 @@ MODULE DOF_ConstructorMethods
!@endnote
INTERFACE Initiate
- MODULE PURE SUBROUTINE obj_initiate1(obj, tNodes, Names, spacecompo, &
- & timecompo, StorageFMT)
+ MODULE PURE SUBROUTINE obj_Initiate1(obj, tNodes, names, spacecompo, &
+ timecompo, storagefmt)
CLASS(DOF_), INTENT(INOUT) :: obj
!! degree of freedom object
INTEGER(I4B), INTENT(IN) :: tNodes(:)
!! number of nodes for each physical variable
- CHARACTER(1), INTENT(IN) :: Names(:)
- !! Names of each physical variable
+ CHARACTER(1), INTENT(IN) :: names(:)
+ !! names of each physical variable
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
!! Space component of each physical variable
INTEGER(I4B), INTENT(IN) :: timecompo(:)
!! Time component of each physical variable
- INTEGER(I4B), INTENT(IN) :: StorageFMT
+ INTEGER(I4B), INTENT(IN) :: storagefmt
!! Storage format `FMT_DOF`, `FMT_Nodes`
- END SUBROUTINE obj_initiate1
+ END SUBROUTINE obj_Initiate1
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -83,18 +83,18 @@ END SUBROUTINE obj_initiate1
!
!# Introduction
!
-! This subroutine initiates a fortran vector (rank-1 fortran array ) of
+! This subroutine Initiates a fortran vector (rank-1 fortran array ) of
! real using the information stored inside DOF_ object. This subroutine
! gets the size of array from the DOF_ object and then reallocates
! `val` and set its all values to zero.
INTERFACE Initiate
- MODULE PURE SUBROUTINE obj_initiate2(val, obj)
+ MODULE PURE SUBROUTINE obj_Initiate2(val, obj)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: val(:)
- !! This vector will be initiated by using obj
+ !! This vector will be Initiated by using obj
CLASS(DOF_), INTENT(IN) :: obj
!! DOF object
- END SUBROUTINE obj_initiate2
+ END SUBROUTINE obj_Initiate2
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -107,14 +107,14 @@ END SUBROUTINE obj_initiate2
!
!# Introduction
!
-! This subroutine can initiate two fortran vectors (rank-1 fortran arrays)
+! This subroutine can Initiate two fortran vectors (rank-1 fortran arrays)
! using the information stored inside the DOF_ object
INTERFACE Initiate
- MODULE PURE SUBROUTINE obj_initiate3(Val1, Val2, obj)
+ MODULE PURE SUBROUTINE obj_Initiate3(Val1, Val2, obj)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Val1(:), Val2(:)
CLASS(DOF_), INTENT(IN) :: obj
- END SUBROUTINE obj_initiate3
+ END SUBROUTINE obj_Initiate3
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -130,14 +130,14 @@ END SUBROUTINE obj_initiate3
! This routine copy obj2 into obj1. It also define an assignment operator
INTERFACE Initiate
- MODULE PURE SUBROUTINE obj_initiate4(obj1, obj2)
+ MODULE PURE SUBROUTINE obj_Initiate4(obj1, obj2)
CLASS(DOF_), INTENT(INOUT) :: obj1
CLASS(DOF_), INTENT(IN) :: obj2
- END SUBROUTINE obj_initiate4
+ END SUBROUTINE obj_Initiate4
END INTERFACE Initiate
INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE obj_initiate4
+ MODULE PROCEDURE obj_Initiate4
END INTERFACE ASSIGNMENT(=)
!----------------------------------------------------------------------------
@@ -155,12 +155,12 @@ END SUBROUTINE obj_initiate4
! for more see dof_
INTERFACE DOF
- MODULE PURE FUNCTION obj_Constructor1(tNodes, Names, spacecompo, timecompo, &
- & StorageFMT) RESULT(obj)
+ MODULE PURE FUNCTION obj_Constructor1(tNodes, names, spacecompo, timecompo, &
+ & storagefmt) RESULT(obj)
TYPE(DOF_) :: obj
INTEGER(I4B), INTENT(IN) :: tNodes(:), spacecompo(:), &
- & timecompo(:), StorageFMT
- CHARACTER(1), INTENT(IN) :: Names(:)
+ & timecompo(:), storagefmt
+ CHARACTER(1), INTENT(IN) :: names(:)
END FUNCTION obj_Constructor1
END INTERFACE DOF
@@ -178,19 +178,19 @@ END FUNCTION obj_Constructor1
! for more see dof_
INTERFACE DOF_Pointer
- MODULE FUNCTION obj_Constructor_1(tNodes, Names, spacecompo, timecompo, &
- & StorageFMT) RESULT(obj)
+ MODULE FUNCTION obj_Constructor_1(tNodes, names, spacecompo, timecompo, &
+ & storagefmt) RESULT(obj)
CLASS(DOF_), POINTER :: obj
!! dof_ object
INTEGER(I4B), INTENT(IN) :: tNodes(:)
!! total number of nodes for each dof
- CHARACTER(1), INTENT(IN) :: Names(:)
+ CHARACTER(1), INTENT(IN) :: names(:)
!! name of each dof
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
!! space components for each dof
INTEGER(I4B), INTENT(IN) :: timecompo(:)
!! time component for each dof
- INTEGER(I4B), INTENT(IN) :: StorageFMT
+ INTEGER(I4B), INTENT(IN) :: storagefmt
!! storage format for dof
END FUNCTION obj_Constructor_1
END INTERFACE DOF_Pointer
diff --git a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90 b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90
index dfa236fbd..899f090fd 100644
--- a/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90
+++ b/src/modules/DiffusionMatrix/src/DiffusionMatrix_Method.F90
@@ -20,15 +20,23 @@
! summary: This module contains method to construct finite element matrices
MODULE DiffusionMatrix_Method
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: ElemShapeData_, &
+ FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: DiffusionMatrix
+PUBLIC :: DiffusionMatrix_
!----------------------------------------------------------------------------
-! DiffusionMatrix@DiffusionMatrixMethods
+! DiffusionMatrix
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -51,19 +59,33 @@ MODULE DiffusionMatrix_Method
! {\partial x_{k}}\frac{\partial N^{J}}{\partial x_{k}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_1(test, trial, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
CLASS(ElemshapeData_), INTENT(IN) :: trial
INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_1
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_1
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+! DiffusionMatrix_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-28
+! summary: DiffusionMatrix_1 without allocation
+
+INTERFACE DiffusionMatrix_
+ MODULE PURE SUBROUTINE DiffusionMatrix1_(test, trial, ans, nrow, ncol, opt)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ END SUBROUTINE DiffusionMatrix1_
+END INTERFACE DiffusionMatrix_
+
!----------------------------------------------------------------------------
! DiffusionMatrix@DiffusionMatrixMethods
!----------------------------------------------------------------------------
@@ -80,7 +102,7 @@ END FUNCTION DiffusionMatrix_1
! $$
!
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) &
& RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -94,12 +116,25 @@ MODULE PURE FUNCTION DiffusionMatrix_2(test, trial, k, krank, opt) &
INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_2
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_2
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE DiffusionMatrix_
+ MODULE PURE SUBROUTINE DiffusionMatrix2_(test, trial, k, krank, opt, &
+ ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: k
+ TYPE(FEVariableScalar_), INTENT(IN) :: krank
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE DiffusionMatrix2_
+END INTERFACE DiffusionMatrix_
+
!----------------------------------------------------------------------------
! DiffusionMatrix@DiffusionMatrixMethods
!----------------------------------------------------------------------------
@@ -115,7 +150,7 @@ END FUNCTION DiffusionMatrix_2
! \frac{\partial N^{J}}{\partial x_{j}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) &
& RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -129,12 +164,25 @@ MODULE PURE FUNCTION DiffusionMatrix_3(test, trial, k, krank, opt) &
INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_3
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_3
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE DiffusionMatrix_
+ MODULE PURE SUBROUTINE DiffusionMatrix3_(test, trial, k, krank, opt, &
+ ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: k
+ TYPE(FEVariableVector_), INTENT(IN) :: krank
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE DiffusionMatrix3_
+END INTERFACE DiffusionMatrix_
+
!----------------------------------------------------------------------------
! DiffusionMatrix@DiffusionMatrixMethods
!----------------------------------------------------------------------------
@@ -150,7 +198,7 @@ END FUNCTION DiffusionMatrix_3
! \frac{\partial N^{J}}{\partial x_{j}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) &
& RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -165,12 +213,25 @@ MODULE PURE FUNCTION DiffusionMatrix_4(test, trial, k, krank, opt) &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_4
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_4
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE DiffusionMatrix_
+ MODULE PURE SUBROUTINE DiffusionMatrix4_(test, trial, k, krank, opt, &
+ ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: k
+ TYPE(FEVariableMatrix_), INTENT(IN) :: krank
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE DiffusionMatrix4_
+END INTERFACE DiffusionMatrix_
+
!----------------------------------------------------------------------------
! DiffusionMatrix@DiffusionMatrixMethods
!----------------------------------------------------------------------------
@@ -186,7 +247,7 @@ END FUNCTION DiffusionMatrix_4
! \frac{\partial N^{J}}{\partial x_{j}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -205,12 +266,27 @@ MODULE PURE FUNCTION DiffusionMatrix_5(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_5
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_5
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE DiffusionMatrix_
+ MODULE PURE SUBROUTINE DiffusionMatrix5_(test, trial, c1, c2, c1rank, &
+ c2rank, opt, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: c1
+ CLASS(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE DiffusionMatrix5_
+END INTERFACE DiffusionMatrix_
+
!----------------------------------------------------------------------------
! DiffusionMatrix@DiffusionMatrixMethods
!----------------------------------------------------------------------------
@@ -226,7 +302,7 @@ END FUNCTION DiffusionMatrix_5
! \frac{\partial N^{J}}{\partial x_{j}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -245,12 +321,27 @@ MODULE PURE FUNCTION DiffusionMatrix_6(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_6
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_6
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE DiffusionMatrix_
+ MODULE PURE SUBROUTINE DiffusionMatrix6_(test, trial, c1, c2, c1rank, &
+ c2rank, opt, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: c1
+ CLASS(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE DiffusionMatrix6_
+END INTERFACE DiffusionMatrix_
+
!----------------------------------------------------------------------------
! DiffusionMatrix@DiffusionMatrixMethods
!----------------------------------------------------------------------------
@@ -266,7 +357,7 @@ END FUNCTION DiffusionMatrix_6
! \frac{\partial N^{J}}{\partial x_{j}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_7(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -285,10 +376,6 @@ MODULE PURE FUNCTION DiffusionMatrix_7(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_7
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_7
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -305,7 +392,7 @@ END FUNCTION DiffusionMatrix_7
!
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_8(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -324,10 +411,6 @@ MODULE PURE FUNCTION DiffusionMatrix_8(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_8
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_8
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -344,7 +427,7 @@ END FUNCTION DiffusionMatrix_8
!
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_9(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -363,10 +446,6 @@ MODULE PURE FUNCTION DiffusionMatrix_9(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_9
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_9
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -377,7 +456,7 @@ END FUNCTION DiffusionMatrix_9
! date: 6 March 2021
! summary: This subroutine returns the diffusion matrix in space domain
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_10(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -396,10 +475,6 @@ MODULE PURE FUNCTION DiffusionMatrix_10(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_10
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_10
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -410,7 +485,7 @@ END FUNCTION DiffusionMatrix_10
! date: 6 March 2021
! summary: This subroutine returns the diffusion matrix in space domain
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_11(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -429,10 +504,6 @@ MODULE PURE FUNCTION DiffusionMatrix_11(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_11
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_11
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -443,7 +514,7 @@ END FUNCTION DiffusionMatrix_11
! date: 6 March 2021
! summary: This subroutine returns the diffusion matrix in space domain
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_12(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -462,10 +533,6 @@ MODULE PURE FUNCTION DiffusionMatrix_12(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_12
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_12
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -476,7 +543,7 @@ END FUNCTION DiffusionMatrix_12
! date: 6 March 2021
! summary: This subroutine returns the diffusion matrix in space domain
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_13(test, trial, c1, c2, c1rank, &
& c2rank, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -495,10 +562,6 @@ MODULE PURE FUNCTION DiffusionMatrix_13(test, trial, c1, c2, c1rank, &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_13
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_13
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -525,17 +588,13 @@ END FUNCTION DiffusionMatrix_13
! \frac{\partial N^{J}}{\partial x_{i}}d\Omega
! $$
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_14(test, trial, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
CLASS(ElemshapeData_), INTENT(IN) :: trial
INTEGER(I4B), INTENT(IN) :: opt(1)
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_14
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_14
END INTERFACE DiffusionMatrix
!----------------------------------------------------------------------------
@@ -554,7 +613,7 @@ END FUNCTION DiffusionMatrix_14
! $$
!
-INTERFACE
+INTERFACE DiffusionMatrix
MODULE PURE FUNCTION DiffusionMatrix_15(test, trial, k, krank, opt) &
& RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
@@ -568,10 +627,10 @@ MODULE PURE FUNCTION DiffusionMatrix_15(test, trial, k, krank, opt) &
INTEGER(I4B), INTENT(IN) :: opt(1)
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION DiffusionMatrix_15
-END INTERFACE
-
-INTERFACE DiffusionMatrix
- MODULE PROCEDURE DiffusionMatrix_15
END INTERFACE DiffusionMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE DiffusionMatrix_Method
diff --git a/src/modules/Display/src/Display_Method.F90 b/src/modules/Display/src/Display_Method.F90
index 2a7fd7d35..c516de534 100755
--- a/src/modules/Display/src/Display_Method.F90
+++ b/src/modules/Display/src/Display_Method.F90
@@ -43,17 +43,16 @@ MODULE Display_Method
CHARACTER(*), PARAMETER :: COLOR_BG = "BLACK"
CHARACTER(*), PARAMETER :: COLOR_STYLE = "BOLD_ON"
-TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: &
- & DisplayProfileTerminal = DISP_SETTINGS(&
- & advance="YES", matsep=",", orient="COL", style="UNDERLINE", &
- & trim="FALSE", ZEROAS=".")
+TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: DisplayProfileTerminal = &
+ DISP_SETTINGS(advance="YES", matsep=",", orient="COL", style="UNDERLINE", &
+ trim="FALSE", ZEROAS=".")
-TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: &
- & DisplayProfilePrint = DISP_SETTINGS(&
- & advance="YES", matsep=",", orient="COL", style="UNDERLINE", &
- & trim="FALSE", ZEROAS="")
+TYPE(DISP_SETTINGS), PUBLIC, PARAMETER :: DisplayProfilePrint = &
+ DISP_SETTINGS(advance="YES", matsep=",", orient="COL", style="UNDERLINE", &
+ trim="FALSE", ZEROAS="")
+
+! TYPE(DISP_SETTINGS), PARAMETER :: DisplayProfileOriginal = DISP_SETTINGS()
-TYPE(DISP_SETTINGS), PARAMETER :: DisplayProfileOriginal = DISP_SETTINGS()
LOGICAL(LGT) :: defaultSettingSet = .FALSE.
!----------------------------------------------------------------------------
diff --git a/src/modules/Display/src/disp/disp_charmod.F90 b/src/modules/Display/src/disp/disp_charmod.F90
index cd12e191e..98f8cc22a 100755
--- a/src/modules/Display/src/disp/disp_charmod.F90
+++ b/src/modules/Display/src/disp/disp_charmod.F90
@@ -11,7 +11,7 @@
MODULE DISP_CHARMOD
USE DISPMODULE_UTIL
-USE GlobalData, ONLY: Real32
+USE GlobalData, ONLY: REAL32
PRIVATE
PUBLIC DISP
@@ -27,59 +27,59 @@ MODULE DISP_CHARMOD
subroutine disp_v_dchr(x, fmt, advance, lbound, sep, style, trim, unit, orient)
! Default character vector without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient
- character(*), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tv_dchr('', x, fmt, advance, lbound, sep, style, trim, unit, orient)
-end subroutine disp_v_dchr
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient
+ CHARACTER(*), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+CALL disp_tv_dchr('', x, fmt, advance, lbound, sep, style, trim, unit, orient)
+END SUBROUTINE disp_v_dchr
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-subroutine disp_m_dchr(x, fmt, advance, lbound, sep, style, trim, unit)
+SUBROUTINE disp_m_dchr(x, fmt, advance, lbound, sep, style, trim, unit)
! Default character matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim
- character(*), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tm_dchr('', x, fmt, advance, lbound, sep, style, trim, unit)
-end subroutine disp_m_dchr
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim
+ CHARACTER(*), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ CALL disp_tm_dchr('', x, fmt, advance, lbound, sep, style, trim, unit)
+END SUBROUTINE disp_m_dchr
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-subroutine disp_ts_dchr(title, x, fmt, advance, sep, style, trim, unit)
+SUBROUTINE disp_ts_dchr(title, x, fmt, advance, sep, style, trim, unit)
! Default character scalar with title
- character(*), intent(in), optional :: title, x, fmt, advance, sep, style, trim
- character(0) empty(1,0)
- integer, intent(in), optional :: unit
+CHARACTER(*), INTENT(in), OPTIONAL :: title, x, fmt, advance, sep, style, trim
+ CHARACTER(0) empty(1, 0)
+ INTEGER, INTENT(in), OPTIONAL :: unit
empty = ''
- if (present(title).and.present(x)) then
+ IF (PRESENT(title) .AND. PRESENT(x)) THEN
call disp_nonopt_dchr(title, x, fmt, advance, sep=sep, style=style, trim=trim, unit=unit)
- elseif (present(x)) then
+ ELSEIF (PRESENT(x)) THEN
call disp_nonopt_dchr('', x, fmt, advance, sep=sep, style='left', trim=trim, unit=unit)
- elseif (present(title)) then
+ ELSEIF (PRESENT(title)) THEN
call disp_nonopt_dchr('', title, fmt, advance, sep=sep, style='left', trim=trim, unit=unit)
- else
+ ELSE
call disp_tm_dchr('', empty, fmt, advance, sep=sep, style=style, trim=trim, unit=unit)
- end if
-end subroutine disp_ts_dchr
+ END IF
+END SUBROUTINE disp_ts_dchr
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-subroutine disp_nonopt_dchr(title, x, fmt, advance, sep, style, trim, unit)
+SUBROUTINE disp_nonopt_dchr(title, x, fmt, advance, sep, style, trim, unit)
! This routine exists to circumvent bug in gfortran, that made it not possible to change scalar strings
! to matrices with reshape in calls of disp_tm_dchr. This intermediate routine provides work-around.
- character(*), intent(in) :: title, x, fmt, advance, sep, style, trim
- optional fmt, advance, sep, style, trim
- integer, intent(in), optional :: unit
- character(len(x)) :: xm(1,1)
- xm(1,1) = x
+ CHARACTER(*), INTENT(in) :: title, x, fmt, advance, sep, style, trim
+ OPTIONAL fmt, advance, sep, style, trim
+ INTEGER, INTENT(in), OPTIONAL :: unit
+ CHARACTER(LEN(x)) :: xm(1, 1)
+ xm(1, 1) = x
call disp_tm_dchr(title, xm, fmt, advance, sep=sep, style=style, trim=trim, unit=unit)
-end subroutine disp_nonopt_dchr
+END SUBROUTINE disp_nonopt_dchr
!----------------------------------------------------------------------------
!
@@ -87,17 +87,17 @@ end subroutine disp_nonopt_dchr
subroutine disp_tv_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit, orient)
! Default character vector with title
- character(*), intent(in) :: title, x(:)
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient
- integer, intent(in), optional :: unit, lbound(:)
- type(settings) :: SE
+ CHARACTER(*), INTENT(in) :: title, x(:)
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient)
- if (SE%row) then
- call disp_dchr(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_dchr(title, reshape(x, (/size(x), 1/)), SE)
- end if
-end subroutine disp_tv_dchr
+ IF (SE%row) THEN
+ CALL disp_dchr(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_dchr(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_dchr
!----------------------------------------------------------------------------
!
@@ -105,71 +105,71 @@ end subroutine disp_tv_dchr
subroutine disp_tm_dchr(title, x, fmt, advance, lbound, sep, style, trim, unit)
! Default character matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- character(*), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'A4')
- integer, intent(in), optional :: unit ! Unit to display on
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: style ! Style(s): see NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ CHARACTER(*), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'A4')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): see NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
!
- type(settings) :: SE
- call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit)
- call disp_dchr(title, x, SE)
-end subroutine disp_tm_dchr
+ TYPE(settings) :: SE
+CALL get_SE(SE, title, SHAPE(x), fmt, advance, lbound, sep, style, trim, unit)
+ CALL disp_dchr(title, x, SE)
+END SUBROUTINE disp_tm_dchr
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-subroutine disp_dchr(title, x, SE)
+SUBROUTINE disp_dchr(title, x, SE)
! Default character item to box
- character(*), intent(in) :: title, x(:,:)
- type(settings), intent(INOUT ) :: SE
- character(13) :: edesc
- character, pointer :: boxp(:,:)
- integer :: m, n, j, lin1, wleft, lx, w
- integer, dimension(size(x,2)) :: wid, nbl, n1, n2, widp
- m = size(x,1)
- n = size(x,2)
- lx = len(x)
+ CHARACTER(*), INTENT(in) :: title, x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ CHARACTER(13) :: edesc
+ CHARACTER, POINTER :: boxp(:, :)
+ INTEGER :: m, n, j, lin1, wleft, lx, w
+ INTEGER, DIMENSION(SIZE(x, 2)) :: wid, nbl, n1, n2, widp
+ m = SIZE(x, 1)
+ n = SIZE(x, 2)
+ lx = LEN(x)
w = SE%w
- if (w <= 0) then
+ IF (w <= 0) THEN
w = lx
- if (w < 0) then
+ IF (w < 0) THEN
edesc = '(A__________)'
- write(edesc(3:12), '(SS,I10)') w
+ WRITE (edesc(3:12), '(SS,I10)') w
SE%ed = edesc
- end if
- end if
- if (SE%trm .and. size(x) > 0) then
- n1 = minval(mod(verify(x, ' ') - w - 1, w + 1), 1) + w + 1
- n2 = maxval(verify(x, ' ', back = .true.), 1)
+ END IF
+ END IF
+ IF (SE%trm .AND. SIZE(x) > 0) THEN
+ n1 = MINVAL(MOD(VERIFY(x, ' ') - w - 1, w + 1), 1) + w + 1
+ n2 = MAXVAL(VERIFY(x, ' ', back=.TRUE.), 1)
wid = n2 - n1 + 1
nbl = w - wid
- else
+ ELSE
n1 = 1
n2 = w
wid = w
nbl = 0
- end if
- if (all(wid == 0)) n = 0
+ END IF
+ IF (ALL(wid == 0)) n = 0
SE%w = w
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (SE%trm) then
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ IF (SE%trm) THEN
call copytobox(x(:,j)(n1(j):n2(j)), lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- else
+ ELSE
if (widp(j) > lx) call copyseptobox(repeat(' ', widp(j)-lx), m, lin1, boxp, wleft)
- call copytobox(x(:,j), lin1, lx, lx, 0, boxp, wleft)
- end if
- if (j 0) write(s, SE%ed) x(:,j)
- if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j 0) WRITE (s, SE%ed) x(:, j)
+ IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0)
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_byte
- subroutine find_editdesc_byte(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid
- integer(byte), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(out) :: wid(size(x,2)), nbl(size(x,2))
- !
- integer(byte) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm
- logical xzero(size(x,2)), xallz(size(x,2))
- character(22) s
- integer ww
- !
- if (SE%w == 0) then
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- SE%w = max(SE%lzas, ww)
- call replace_w(SE%ed, ww)
- elseif (SE%w < 0) then ! obtain max-width of x
- if (size(x) == 0) then
- SE%ed = '()'
- SE%w = 0
- wid = 0
- return
- endif
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- ww = max(SE%lzas, ww)
- SE%ed = '(SS,Ixx)'
- write(SE%ed(6:7), '(SS,I2)') ww
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1) ! max in each column
- xminv = minval(x, 1) ! min
- xzero = any(x == 0_byte, 1) ! true where column has some zeros
- xallz = all(x == 0_byte, 1) ! true where column has only zeros
- call getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- else
- wid = SE%w
- nbl = 0
- endif
- end subroutine find_editdesc_byte
+SUBROUTINE find_editdesc_byte(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid
+ INTEGER(byte), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ !
+ INTEGER(byte) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm
+ LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2))
+ CHARACTER(22) s
+ INTEGER ww
+ !
+ IF (SE%w == 0) THEN
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ SE%w = MAX(SE%lzas, ww)
+ CALL replace_w(SE%ed, ww)
+ ELSEIF (SE%w < 0) THEN ! obtain max-width of x
+ IF (SIZE(x) == 0) THEN
+ SE%ed = '()'
+ SE%w = 0
+ wid = 0
+ RETURN
+ END IF
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ ww = MAX(SE%lzas, ww)
+ SE%ed = '(SS,Ixx)'
+ WRITE (SE%ed(6:7), '(SS,I2)') ww
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1) ! max in each column
+ xminv = MINVAL(x, 1) ! min
+ xzero = ANY(x == 0_BYTE, 1) ! true where column has some zeros
+ xallz = ALL(x == 0_BYTE, 1) ! true where column has only zeros
+ CALL getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_byte
- subroutine getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- integer(byte), intent(in) :: xmaxv(:), xminv(:)
- logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
- type(settings), intent(in) :: SE ! Settings
- integer, intent(out) :: wid(:) ! Widths of columns
- integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmax, SE%ed) xmaxv
- write(stmin, SE%ed) xminv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- wid = w - nbl
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- nbl = w - wid
- endif
- end subroutine getwid_byte
+SUBROUTINE getwid_byte(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ INTEGER(byte), INTENT(in) :: xmaxv(:), xminv(:)
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
+ TYPE(settings), INTENT(in) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(:) ! Widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmax, SE%ed) xmaxv
+ WRITE (stmin, SE%ed) xminv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ wid = w - nbl
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ nbl = w - wid
+ END IF
+END SUBROUTINE getwid_byte
- ! ********* 1-BYTE INTEGER TOSTRING PROCEDURES *********
- function tostring_s_byte(x) result(st)
- ! Scalar to string
- integer(byte), intent(in) :: x
- character(len_f_byte((/x/), tosset0%ifmt)) :: st
- st = tostring_f_byte((/x/), tosset0%ifmt)
- end function tostring_s_byte
+! ********* 1-BYTE INTEGER TOSTRING PROCEDURES *********
+FUNCTION tostring_s_byte(x) RESULT(st)
+ ! Scalar to string
+ INTEGER(byte), INTENT(in) :: x
+ CHARACTER(len_f_byte((/x/), tosset0%ifmt)) :: st
+ st = tostring_f_byte((/x/), tosset0%ifmt)
+END FUNCTION tostring_s_byte
- function tostring_sf_byte(x, fmt) result(st)
- ! Scalar with specified format to string
- integer(byte),intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_byte((/x/), fmt)) :: st
- st = tostring_f_byte((/x/), fmt)
- end function tostring_sf_byte
+FUNCTION tostring_sf_byte(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ INTEGER(byte), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byte((/x/), fmt)) :: st
+ st = tostring_f_byte((/x/), fmt)
+END FUNCTION tostring_sf_byte
- function tostring_byte(x) result(st)
- ! Vector to string
- integer(byte), intent(in) :: x(:)
- character(len_f_byte(x, tosset0%ifmt)) :: st
- st = tostring_f_byte(x, tosset0%ifmt)
- end function tostring_byte
+FUNCTION tostring_byte(x) RESULT(st)
+ ! Vector to string
+ INTEGER(byte), INTENT(in) :: x(:)
+ CHARACTER(len_f_byte(x, tosset0%ifmt)) :: st
+ st = tostring_f_byte(x, tosset0%ifmt)
+END FUNCTION tostring_byte
- function tostring_f_byte(x, fmt) result(st)
- ! Vector with specified format to string
- integer(byte), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_byte(x, fmt)) :: st
- character(widthmax_byte(x, fmt)) :: sa(size(x))
- integer :: w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; st = errormsg; return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- call tostring_get(sa, st)
- end function tostring_f_byte
+FUNCTION tostring_f_byte(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ INTEGER(byte), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byte(x, fmt)) :: st
+ CHARACTER(widthmax_byte(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; st = errormsg; RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_byte
- pure function len_f_byte(x, fmt) result(wtot)
- ! Total width of tostring representation of x
- integer(byte), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_byte(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_byte
+PURE FUNCTION len_f_byte(x, fmt) RESULT(wtot)
+ ! Total width of tostring representation of x
+ INTEGER(byte), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_byte(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_byte
- pure function widthmax_byte(x, fmt) result(w)
- ! Maximum width of string representation of an element in x
- integer(byte), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(range(x)+2) sx(2)
- integer w, d
- logical gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w<=0) then
- write(sx, '(SS,I0)') maxval(x), minval(x)
- w = maxval(len_trim(sx))
- end if
- end function widthmax_byte
+PURE FUNCTION widthmax_byte(x, fmt) RESULT(w)
+ ! Maximum width of string representation of an element in x
+ INTEGER(byte), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(RANGE(x) + 2) sx(2)
+ INTEGER w, d
+ LOGICAL gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) THEN
+ WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x)
+ w = MAXVAL(LEN_TRIM(sx))
+ END IF
+END FUNCTION widthmax_byte
END MODULE DISP_I1MOD
diff --git a/src/modules/Display/src/disp/disp_i2mod.F90 b/src/modules/Display/src/disp/disp_i2mod.F90
index 3fa00b9b5..2047c0976 100755
--- a/src/modules/Display/src/disp/disp_i2mod.F90
+++ b/src/modules/Display/src/disp/disp_i2mod.F90
@@ -1,276 +1,276 @@
MODULE DISP_I2MOD
- ! Add-on module to DISPMODULE to display 2-byte integers
- ! (assuming that these are obtained with selected_int_kind(4))
- !
- ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from
- ! from dispmodule.F90, replacing dint with byt2 and default integer' with 2-byte
- ! integer (only appears in comments), and adding the DECLARATIONS section below.
- !
- ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
- ! Iceland (jonasson@hi.is). This software is free. For details see the file README.
+! Add-on module to DISPMODULE to display 2-byte integers
+! (assuming that these are obtained with selected_int_kind(4))
+!
+! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from
+! from dispmodule.F90, replacing dint with byt2 and default integer' with 2-byte
+! integer (only appears in comments), and adding the DECLARATIONS section below.
+!
+! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
+! Iceland (jonasson@hi.is). This software is free. For details see the file README.
- ! ******************************** DECLARATIONS ********************************************
- USE DISPMODULE_UTIL
- USE GlobalData, ONLY: Int16
- IMPLICIT NONE
- PRIVATE
+! ******************************** DECLARATIONS ********************************************
+USE DISPMODULE_UTIL
+USE GlobalData, ONLY: INT16
+IMPLICIT NONE
+PRIVATE
- PUBLIC DISP
- PUBLIC TOSTRING
+PUBLIC DISP
+PUBLIC TOSTRING
- interface Display
+INTERFACE Display
module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2
- end interface
+END INTERFACE
- interface disp
+INTERFACE disp
module procedure disp_s_byt2, disp_ts_byt2, disp_v_byt2, disp_tv_byt2, disp_m_byt2, disp_tm_byt2
- end interface
+END INTERFACE
- interface tostring
+INTERFACE tostring
module procedure tostring_byt2, tostring_f_byt2, tostring_s_byt2, tostring_sf_byt2
- end interface
+END INTERFACE
- ! integer, parameter :: byt2 = selected_int_kind(4)
- integer, parameter :: byt2 = Int16
+! integer, parameter :: byt2 = selected_int_kind(4)
+INTEGER, PARAMETER :: byt2 = INT16
CONTAINS
- ! ******************************** 2-BYTE INTEGER PROCEDURES *******************************
- subroutine disp_s_byt2(x, fmt, advance, sep, trim, unit, zeroas)
- ! 2-byte integer scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
- integer(byt2), intent(in) :: x
- integer, intent(in), optional :: unit
- call disp_ts_byt2('', x, fmt, advance, sep, 'left', trim, unit, zeroas)
- end subroutine disp_s_byt2
+! ******************************** 2-BYTE INTEGER PROCEDURES *******************************
+SUBROUTINE disp_s_byt2(x, fmt, advance, sep, trim, unit, zeroas)
+ ! 2-byte integer scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas
+ INTEGER(byt2), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
+ CALL disp_ts_byt2('', x, fmt, advance, sep, 'left', trim, unit, zeroas)
+END SUBROUTINE disp_s_byt2
subroutine disp_v_byt2(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- ! 2-byte integer vector without title
+ ! 2-byte integer vector without title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- integer(byt2), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
+ INTEGER(byt2), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
call disp_tv_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- end subroutine disp_v_byt2
+END SUBROUTINE disp_v_byt2
subroutine disp_m_byt2(x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- ! 2-byte integer matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- integer(byt2), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tm_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- end subroutine disp_m_byt2
+ ! 2-byte integer matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ INTEGER(byt2), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+CALL disp_tm_byt2('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
+END SUBROUTINE disp_m_byt2
subroutine disp_ts_byt2(title, x, fmt, advance, sep, style, trim, unit, zeroas)
- ! 2-byte integer scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- integer(byt2), intent(in) :: x
- integer, intent(in), optional :: unit
+ ! 2-byte integer scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ INTEGER(byt2), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
call disp_tm_byt2(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, &
- zeroas=zeroas)
- end subroutine disp_ts_byt2
+ zeroas=zeroas)
+END SUBROUTINE disp_ts_byt2
subroutine disp_tv_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- ! 2-byte integer vector with title
- character(*), intent(in) :: title
+ ! 2-byte integer vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- integer(byt2), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
- type(settings) :: SE
+ INTEGER(byt2), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- if (SE%row) then
- call disp_byt2(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_byt2(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_byt2
+ IF (SE%row) THEN
+ CALL disp_byt2(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_byt2(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_byt2
subroutine disp_tm_byt2(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- ! 2-byte integer matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- integer(byt2),intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4')
- integer, intent(in), optional :: unit ! Unit to display on
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
+ ! 2-byte integer matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ INTEGER(byt2), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced by this string
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas)
- call disp_byt2(title, x, SE)
- end subroutine disp_tm_byt2
+ CALL disp_byt2(title, x, SE)
+END SUBROUTINE disp_tm_byt2
- subroutine disp_byt2(title, x, SE)
- ! 2-byte integer item
- character(*), intent(in) :: title
- integer(byt2), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- call find_editdesc_byt2(x, SE, wid, nbl) ! determine also SE%w
- call tobox_byt2(title, x, SE, wid, nbl)
- end subroutine disp_byt2
+SUBROUTINE disp_byt2(title, x, SE)
+ ! 2-byte integer item
+ CHARACTER(*), INTENT(in) :: title
+ INTEGER(byt2), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ CALL find_editdesc_byt2(x, SE, wid, nbl) ! determine also SE%w
+ CALL tobox_byt2(title, x, SE, wid, nbl)
+END SUBROUTINE disp_byt2
- subroutine tobox_byt2(title, x, SE, wid, nbl)
- ! Write 2-byte integer matrix to box
- character(*), intent(in) :: title
- integer(byt2), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(INOUT ) :: wid(:)
- integer, intent(INOUT ) :: nbl(:)
- character(SE%w) :: s(size(x,1))
- integer :: lin1, j, wleft, m, n, widp(size(wid))
- character, pointer :: boxp(:,:)
- m = size(x,1)
- n = size(x,2)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) x(:,j)
- if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j 0) WRITE (s, SE%ed) x(:, j)
+ IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0)
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_byt2
- subroutine find_editdesc_byt2(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid
- integer(byt2), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(out) :: wid(size(x,2)), nbl(size(x,2))
- !
- integer(byt2) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm
- logical xzero(size(x,2)), xallz(size(x,2))
- character(22) s
- integer ww
- !
- if (SE%w == 0) then
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- SE%w = max(SE%lzas, ww)
- call replace_w(SE%ed, ww)
- elseif (SE%w < 0) then ! obtain max-width of x
- if (size(x) == 0) then
- SE%ed = '()'
- SE%w = 0
- wid = 0
- return
- endif
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- ww = max(SE%lzas, ww)
- SE%ed = '(SS,Ixx)'
- write(SE%ed(6:7), '(SS,I2)') ww
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1) ! max in each column
- xminv = minval(x, 1) ! min
- xzero = any(x == 0_byt2, 1) ! true where column has some zeros
- xallz = all(x == 0_byt2, 1) ! true where column has only zeros
- call getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- else
- wid = SE%w
- nbl = 0
- endif
- end subroutine find_editdesc_byt2
+SUBROUTINE find_editdesc_byt2(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid
+ INTEGER(byt2), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ !
+ INTEGER(byt2) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm
+ LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2))
+ CHARACTER(22) s
+ INTEGER ww
+ !
+ IF (SE%w == 0) THEN
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ SE%w = MAX(SE%lzas, ww)
+ CALL replace_w(SE%ed, ww)
+ ELSEIF (SE%w < 0) THEN ! obtain max-width of x
+ IF (SIZE(x) == 0) THEN
+ SE%ed = '()'
+ SE%w = 0
+ wid = 0
+ RETURN
+ END IF
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ ww = MAX(SE%lzas, ww)
+ SE%ed = '(SS,Ixx)'
+ WRITE (SE%ed(6:7), '(SS,I2)') ww
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1) ! max in each column
+ xminv = MINVAL(x, 1) ! min
+ xzero = ANY(x == 0_BYT2, 1) ! true where column has some zeros
+ xallz = ALL(x == 0_BYT2, 1) ! true where column has only zeros
+ CALL getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_byt2
- subroutine getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- integer(byt2), intent(in) :: xmaxv(:), xminv(:)
- logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
- type(settings), intent(in) :: SE ! Settings
- integer, intent(out) :: wid(:) ! Widths of columns
- integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmax, SE%ed) xmaxv
- write(stmin, SE%ed) xminv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- wid = w - nbl
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- nbl = w - wid
- endif
- end subroutine getwid_byt2
+SUBROUTINE getwid_byt2(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ INTEGER(byt2), INTENT(in) :: xmaxv(:), xminv(:)
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
+ TYPE(settings), INTENT(in) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(:) ! Widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmax, SE%ed) xmaxv
+ WRITE (stmin, SE%ed) xminv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ wid = w - nbl
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ nbl = w - wid
+ END IF
+END SUBROUTINE getwid_byt2
- ! ********* 2-BYTE INTEGER TOSTRING PROCEDURES *********
- function tostring_s_byt2(x) result(st)
- ! Scalar to string
- integer(byt2), intent(in) :: x
- character(len_f_byt2((/x/), tosset0%ifmt)) :: st
- st = tostring_f_byt2((/x/), tosset0%ifmt)
- end function tostring_s_byt2
+! ********* 2-BYTE INTEGER TOSTRING PROCEDURES *********
+FUNCTION tostring_s_byt2(x) RESULT(st)
+ ! Scalar to string
+ INTEGER(byt2), INTENT(in) :: x
+ CHARACTER(len_f_byt2((/x/), tosset0%ifmt)) :: st
+ st = tostring_f_byt2((/x/), tosset0%ifmt)
+END FUNCTION tostring_s_byt2
- function tostring_sf_byt2(x, fmt) result(st)
- ! Scalar with specified format to string
- integer(byt2),intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_byt2((/x/), fmt)) :: st
- st = tostring_f_byt2((/x/), fmt)
- end function tostring_sf_byt2
+FUNCTION tostring_sf_byt2(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ INTEGER(byt2), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byt2((/x/), fmt)) :: st
+ st = tostring_f_byt2((/x/), fmt)
+END FUNCTION tostring_sf_byt2
- function tostring_byt2(x) result(st)
- ! Vector to string
- integer(byt2), intent(in) :: x(:)
- character(len_f_byt2(x, tosset0%ifmt)) :: st
- st = tostring_f_byt2(x, tosset0%ifmt)
- end function tostring_byt2
+FUNCTION tostring_byt2(x) RESULT(st)
+ ! Vector to string
+ INTEGER(byt2), INTENT(in) :: x(:)
+ CHARACTER(len_f_byt2(x, tosset0%ifmt)) :: st
+ st = tostring_f_byt2(x, tosset0%ifmt)
+END FUNCTION tostring_byt2
- function tostring_f_byt2(x, fmt) result(st)
- ! Vector with specified format to string
- integer(byt2), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_byt2(x, fmt)) :: st
- character(widthmax_byt2(x, fmt)) :: sa(size(x))
- integer :: w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; st = errormsg; return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- call tostring_get(sa, st)
- end function tostring_f_byt2
+FUNCTION tostring_f_byt2(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ INTEGER(byt2), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byt2(x, fmt)) :: st
+ CHARACTER(widthmax_byt2(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; st = errormsg; RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_byt2
- pure function len_f_byt2(x, fmt) result(wtot)
- ! Total width of tostring representation of x
- integer(byt2), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_byt2(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_byt2
+PURE FUNCTION len_f_byt2(x, fmt) RESULT(wtot)
+ ! Total width of tostring representation of x
+ INTEGER(byt2), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_byt2(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_byt2
- pure function widthmax_byt2(x, fmt) result(w)
- ! Maximum width of string representation of an element in x
- integer(byt2), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(range(x)+2) sx(2)
- integer w, d
- logical gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w<=0) then
- write(sx, '(SS,I0)') maxval(x), minval(x)
- w = maxval(len_trim(sx))
- end if
- end function widthmax_byt2
- ! ************************************* END OF 2-BYTE INTEGER PROCEDURES ******************************************
+PURE FUNCTION widthmax_byt2(x, fmt) RESULT(w)
+ ! Maximum width of string representation of an element in x
+ INTEGER(byt2), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(RANGE(x) + 2) sx(2)
+ INTEGER w, d
+ LOGICAL gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) THEN
+ WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x)
+ w = MAXVAL(LEN_TRIM(sx))
+ END IF
+END FUNCTION widthmax_byt2
+! ************************************* END OF 2-BYTE INTEGER PROCEDURES ******************************************
END MODULE DISP_I2MOD
diff --git a/src/modules/Display/src/disp/disp_i4mod.F90 b/src/modules/Display/src/disp/disp_i4mod.F90
index 497fe3d7d..5c7835447 100755
--- a/src/modules/Display/src/disp/disp_i4mod.F90
+++ b/src/modules/Display/src/disp/disp_i4mod.F90
@@ -1,270 +1,270 @@
MODULE DISP_I4MOD
- ! Add-on module to DISPMODULE to display 4-byte integers
- ! (assuming that these are obtained with selected_int_kind(18))
- !
- ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from
- ! from dispmodule.F90, replacing dint with byt4 and 'default integer' with 4-byte
- ! integer (only appears in comments), and adding the DECLARATIONS section below.
- !
- ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
- ! Iceland (jonasson@hi.is). This software is free. For details see the file README.
+! Add-on module to DISPMODULE to display 4-byte integers
+! (assuming that these are obtained with selected_int_kind(18))
+!
+! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from
+! from dispmodule.F90, replacing dint with byt4 and 'default integer' with 4-byte
+! integer (only appears in comments), and adding the DECLARATIONS section below.
+!
+! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
+! Iceland (jonasson@hi.is). This software is free. For details see the file README.
- ! ******************************** DECLARATIONS ********************************************
- USE dispmodule_util
- USE GlobalData, ONLY: Int32
- IMPLICIT NONE
- PRIVATE
- PUBLIC DISP
- PUBLIC TOSTRING
+! ******************************** DECLARATIONS ********************************************
+USE dispmodule_util
+USE GlobalData, ONLY: INT32
+IMPLICIT NONE
+PRIVATE
+PUBLIC DISP
+PUBLIC TOSTRING
- interface disp
+INTERFACE disp
module procedure disp_s_byt4, disp_ts_byt4, disp_v_byt4, disp_tv_byt4, disp_m_byt4, disp_tm_byt4
- end interface
+END INTERFACE
- interface tostring
+INTERFACE tostring
module procedure tostring_byt4, tostring_f_byt4, tostring_s_byt4, tostring_sf_byt4
- end interface
+END INTERFACE
- integer, parameter :: byt4 = Int32
+INTEGER, PARAMETER :: byt4 = INT32
CONTAINS
- ! ******************************** 4-BYTE INTEGER PROCEDURES *******************************
- subroutine disp_s_byt4(x, fmt, advance, sep, trim, unit, zeroas)
- ! 4-byte integer scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
- integer(byt4), intent(in) :: x
- integer, intent(in), optional :: unit
- call disp_ts_byt4('', x, fmt, advance, sep, 'left', trim, unit, zeroas)
- end subroutine disp_s_byt4
+! ******************************** 4-BYTE INTEGER PROCEDURES *******************************
+SUBROUTINE disp_s_byt4(x, fmt, advance, sep, trim, unit, zeroas)
+ ! 4-byte integer scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas
+ INTEGER(byt4), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
+ CALL disp_ts_byt4('', x, fmt, advance, sep, 'left', trim, unit, zeroas)
+END SUBROUTINE disp_s_byt4
subroutine disp_v_byt4(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- ! 4-byte integer vector without title
+ ! 4-byte integer vector without title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- integer(byt4), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
+ INTEGER(byt4), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
call disp_tv_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- end subroutine disp_v_byt4
+END SUBROUTINE disp_v_byt4
subroutine disp_m_byt4(x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- ! 4-byte integer matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- integer(byt4), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tm_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- end subroutine disp_m_byt4
+ ! 4-byte integer matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ INTEGER(byt4), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+CALL disp_tm_byt4('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
+END SUBROUTINE disp_m_byt4
subroutine disp_ts_byt4(title, x, fmt, advance, sep, style, trim, unit, zeroas)
- ! 4-byte integer scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- integer(byt4), intent(in) :: x
- integer, intent(in), optional :: unit
+ ! 4-byte integer scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ INTEGER(byt4), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
call disp_tm_byt4(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, &
- zeroas=zeroas)
- end subroutine disp_ts_byt4
+ zeroas=zeroas)
+END SUBROUTINE disp_ts_byt4
subroutine disp_tv_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- ! 4-byte integer vector with title
- character(*), intent(in) :: title
+ ! 4-byte integer vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- integer(byt4), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
- type(settings) :: SE
+ INTEGER(byt4), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- if (SE%row) then
- call disp_byt4(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_byt4(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_byt4
+ IF (SE%row) THEN
+ CALL disp_byt4(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_byt4(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_byt4
subroutine disp_tm_byt4(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- ! 4-byte integer matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- integer(byt4),intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4')
- integer, intent(in), optional :: unit ! Unit to display on
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
+ ! 4-byte integer matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ INTEGER(byt4), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced by this string
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas)
- call disp_byt4(title, x, SE)
- end subroutine disp_tm_byt4
+ CALL disp_byt4(title, x, SE)
+END SUBROUTINE disp_tm_byt4
- subroutine disp_byt4(title, x, SE)
- ! 4-byte integer item
- character(*), intent(in) :: title
- integer(byt4), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- call find_editdesc_byt4(x, SE, wid, nbl) ! determine also SE%w
- call tobox_byt4(title, x, SE, wid, nbl)
- end subroutine disp_byt4
+SUBROUTINE disp_byt4(title, x, SE)
+ ! 4-byte integer item
+ CHARACTER(*), INTENT(in) :: title
+ INTEGER(byt4), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ CALL find_editdesc_byt4(x, SE, wid, nbl) ! determine also SE%w
+ CALL tobox_byt4(title, x, SE, wid, nbl)
+END SUBROUTINE disp_byt4
- subroutine tobox_byt4(title, x, SE, wid, nbl)
- ! Write 4-byte integer matrix to box
- character(*), intent(in) :: title
- integer(byt4), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(INOUT ) :: wid(:)
- integer, intent(INOUT ) :: nbl(:)
- character(SE%w) :: s(size(x,1))
- integer :: lin1, j, wleft, m, n, widp(size(wid))
- character, pointer :: boxp(:,:)
- m = size(x,1)
- n = size(x,2)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) x(:,j)
- if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j 0) WRITE (s, SE%ed) x(:, j)
+ IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0)
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_byt4
- subroutine find_editdesc_byt4(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid
- integer(byt4), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(out) :: wid(size(x,2)), nbl(size(x,2))
- !
- integer(byt4) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm
- logical xzero(size(x,2)), xallz(size(x,2))
- character(22) s
- integer ww
- !
- if (SE%w == 0) then
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- SE%w = max(SE%lzas, ww)
- call replace_w(SE%ed, ww)
- elseif (SE%w < 0) then ! obtain max-width of x
- if (size(x) == 0) then
- SE%ed = '()'
- SE%w = 0
- wid = 0
- return
- endif
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- ww = max(SE%lzas, ww)
- SE%ed = '(SS,Ixx)'
- write(SE%ed(6:7), '(SS,I2)') ww
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1) ! max in each column
- xminv = minval(x, 1) ! min
- xzero = any(x == 0_byt4, 1) ! true where column has some zeros
- xallz = all(x == 0_byt4, 1) ! true where column has only zeros
- call getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- else
- wid = SE%w
- nbl = 0
- endif
- end subroutine find_editdesc_byt4
+SUBROUTINE find_editdesc_byt4(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid
+ INTEGER(byt4), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ !
+ INTEGER(byt4) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm
+ LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2))
+ CHARACTER(22) s
+ INTEGER ww
+ !
+ IF (SE%w == 0) THEN
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ SE%w = MAX(SE%lzas, ww)
+ CALL replace_w(SE%ed, ww)
+ ELSEIF (SE%w < 0) THEN ! obtain max-width of x
+ IF (SIZE(x) == 0) THEN
+ SE%ed = '()'
+ SE%w = 0
+ wid = 0
+ RETURN
+ END IF
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ ww = MAX(SE%lzas, ww)
+ SE%ed = '(SS,Ixx)'
+ WRITE (SE%ed(6:7), '(SS,I2)') ww
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1) ! max in each column
+ xminv = MINVAL(x, 1) ! min
+ xzero = ANY(x == 0_BYT4, 1) ! true where column has some zeros
+ xallz = ALL(x == 0_BYT4, 1) ! true where column has only zeros
+ CALL getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_byt4
- subroutine getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- integer(byt4), intent(in) :: xmaxv(:), xminv(:)
- logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
- type(settings), intent(in) :: SE ! Settings
- integer, intent(out) :: wid(:) ! Widths of columns
- integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmax, SE%ed) xmaxv
- write(stmin, SE%ed) xminv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- wid = w - nbl
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- nbl = w - wid
- endif
- end subroutine getwid_byt4
+SUBROUTINE getwid_byt4(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ INTEGER(byt4), INTENT(in) :: xmaxv(:), xminv(:)
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
+ TYPE(settings), INTENT(in) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(:) ! Widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmax, SE%ed) xmaxv
+ WRITE (stmin, SE%ed) xminv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ wid = w - nbl
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ nbl = w - wid
+ END IF
+END SUBROUTINE getwid_byt4
- ! ********* 4-BYTE INTEGER TOSTRING PROCEDURES *********
- function tostring_s_byt4(x) result(st)
- ! Scalar to string
- integer(byt4), intent(in) :: x
- character(len_f_byt4((/x/), tosset0%ifmt)) :: st
- st = tostring_f_byt4((/x/), tosset0%ifmt)
- end function tostring_s_byt4
+! ********* 4-BYTE INTEGER TOSTRING PROCEDURES *********
+FUNCTION tostring_s_byt4(x) RESULT(st)
+ ! Scalar to string
+ INTEGER(byt4), INTENT(in) :: x
+ CHARACTER(len_f_byt4((/x/), tosset0%ifmt)) :: st
+ st = tostring_f_byt4((/x/), tosset0%ifmt)
+END FUNCTION tostring_s_byt4
- function tostring_sf_byt4(x, fmt) result(st)
- ! Scalar with specified format to string
- integer(byt4),intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_byt4((/x/), fmt)) :: st
- st = tostring_f_byt4((/x/), fmt)
- end function tostring_sf_byt4
+FUNCTION tostring_sf_byt4(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ INTEGER(byt4), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byt4((/x/), fmt)) :: st
+ st = tostring_f_byt4((/x/), fmt)
+END FUNCTION tostring_sf_byt4
- function tostring_byt4(x) result(st)
- ! Vector to string
- integer(byt4), intent(in) :: x(:)
- character(len_f_byt4(x, tosset0%ifmt)) :: st
- st = tostring_f_byt4(x, tosset0%ifmt)
- end function tostring_byt4
+FUNCTION tostring_byt4(x) RESULT(st)
+ ! Vector to string
+ INTEGER(byt4), INTENT(in) :: x(:)
+ CHARACTER(len_f_byt4(x, tosset0%ifmt)) :: st
+ st = tostring_f_byt4(x, tosset0%ifmt)
+END FUNCTION tostring_byt4
- function tostring_f_byt4(x, fmt) result(st)
- ! Vector with specified format to string
- integer(byt4), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_byt4(x, fmt)) :: st
- character(widthmax_byt4(x, fmt)) :: sa(size(x))
- integer :: w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; st = errormsg; return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- call tostring_get(sa, st)
- end function tostring_f_byt4
+FUNCTION tostring_f_byt4(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ INTEGER(byt4), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byt4(x, fmt)) :: st
+ CHARACTER(widthmax_byt4(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; st = errormsg; RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_byt4
- pure function len_f_byt4(x, fmt) result(wtot)
- ! Total width of tostring representation of x
- integer(byt4), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_byt4(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_byt4
+PURE FUNCTION len_f_byt4(x, fmt) RESULT(wtot)
+ ! Total width of tostring representation of x
+ INTEGER(byt4), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_byt4(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_byt4
- pure function widthmax_byt4(x, fmt) result(w)
- ! Maximum width of string representation of an element in x
- integer(byt4), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(range(x)+2) sx(2)
- integer w, d
- logical gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w<=0) then
- write(sx, '(SS,I0)') maxval(x), minval(x)
- w = maxval(len_trim(sx))
- end if
- end function widthmax_byt4
- ! ************************************* END OF 4-BYTE INTEGER PROCEDURES ******************************************
+PURE FUNCTION widthmax_byt4(x, fmt) RESULT(w)
+ ! Maximum width of string representation of an element in x
+ INTEGER(byt4), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(RANGE(x) + 2) sx(2)
+ INTEGER w, d
+ LOGICAL gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) THEN
+ WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x)
+ w = MAXVAL(LEN_TRIM(sx))
+ END IF
+END FUNCTION widthmax_byt4
+! ************************************* END OF 4-BYTE INTEGER PROCEDURES ******************************************
END MODULE DISP_I4MOD
diff --git a/src/modules/Display/src/disp/disp_i8mod.F90 b/src/modules/Display/src/disp/disp_i8mod.F90
index 54794d25c..63be966de 100755
--- a/src/modules/Display/src/disp/disp_i8mod.F90
+++ b/src/modules/Display/src/disp/disp_i8mod.F90
@@ -1,270 +1,270 @@
MODULE DISP_I8MOD
- ! Add-on module to DISPMODULE to display 8-byte integers
- ! (assuming that these are obtained with selected_int_kind(18))
- !
- ! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from
- ! from dispmodule.F90, replacing dint with byt8 and 'default integer' with 8-byte
- ! integer (only appears in comments), and adding the DECLARATIONS section below.
- !
- ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
- ! Iceland (jonasson@hi.is). This software is free. For details see the file README.
+! Add-on module to DISPMODULE to display 8-byte integers
+! (assuming that these are obtained with selected_int_kind(18))
+!
+! This module is obtained by copying the section DEFAULT INTEGER PROCEDURES from
+! from dispmodule.F90, replacing dint with byt8 and 'default integer' with 8-byte
+! integer (only appears in comments), and adding the DECLARATIONS section below.
+!
+! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
+! Iceland (jonasson@hi.is). This software is free. For details see the file README.
- USE DISPMODULE_UTIL
- use GlobalData, ONLY: Int64
+USE DISPMODULE_UTIL
+USE GlobalData, ONLY: INT64
- PUBLIC DISP
- PUBLIC TOSTRING
+PUBLIC DISP
+PUBLIC TOSTRING
- PRIVATE
+PRIVATE
- interface disp
+INTERFACE disp
module procedure disp_s_byt8, disp_ts_byt8, disp_v_byt8, disp_tv_byt8, disp_m_byt8, disp_tm_byt8
- end interface
+END INTERFACE
- interface tostring
+INTERFACE tostring
module procedure tostring_byt8, tostring_f_byt8, tostring_s_byt8, tostring_sf_byt8
- end interface
+END INTERFACE
- integer, parameter :: byt8 = Int64
+INTEGER, PARAMETER :: byt8 = INT64
CONTAINS
- ! ******************************** 8-BYTE INTEGER PROCEDURES *******************************
- subroutine disp_s_byt8(x, fmt, advance, sep, trim, unit, zeroas)
- ! 8-byte integer scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
- integer(byt8), intent(in) :: x
- integer, intent(in), optional :: unit
- call disp_ts_byt8('', x, fmt, advance, sep, 'left', trim, unit, zeroas)
- end subroutine disp_s_byt8
+! ******************************** 8-BYTE INTEGER PROCEDURES *******************************
+SUBROUTINE disp_s_byt8(x, fmt, advance, sep, trim, unit, zeroas)
+ ! 8-byte integer scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas
+ INTEGER(byt8), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
+ CALL disp_ts_byt8('', x, fmt, advance, sep, 'left', trim, unit, zeroas)
+END SUBROUTINE disp_s_byt8
subroutine disp_v_byt8(x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- ! 8-byte integer vector without title
+ ! 8-byte integer vector without title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- integer(byt8), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
+ INTEGER(byt8), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
call disp_tv_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- end subroutine disp_v_byt8
+END SUBROUTINE disp_v_byt8
subroutine disp_m_byt8(x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- ! 8-byte integer matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- integer(byt8), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tm_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- end subroutine disp_m_byt8
+ ! 8-byte integer matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ INTEGER(byt8), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+CALL disp_tm_byt8('', x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
+END SUBROUTINE disp_m_byt8
subroutine disp_ts_byt8(title, x, fmt, advance, sep, style, trim, unit, zeroas)
- ! 8-byte integer scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- integer(byt8), intent(in) :: x
- integer, intent(in), optional :: unit
+ ! 8-byte integer scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ INTEGER(byt8), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
call disp_tm_byt8(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit, &
- zeroas=zeroas)
- end subroutine disp_ts_byt8
+ zeroas=zeroas)
+END SUBROUTINE disp_ts_byt8
subroutine disp_tv_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- ! 8-byte integer vector with title
- character(*), intent(in) :: title
+ ! 8-byte integer vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- integer(byt8), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
- type(settings) :: SE
+ INTEGER(byt8), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas)
- if (SE%row) then
- call disp_byt8(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_byt8(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_byt8
+ IF (SE%row) THEN
+ CALL disp_byt8(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_byt8(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_byt8
subroutine disp_tm_byt8(title, x, fmt, advance, lbound, sep, style, trim, unit, zeroas)
- ! 8-byte integer matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- integer(byt8),intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4')
- integer, intent(in), optional :: unit ! Unit to display on
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: zeroas ! Zeros are replaced by this string
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
+ ! 8-byte integer matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ INTEGER(byt8), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Format edit descriptor to use for each matrix element (e.g.'I4')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced by this string
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas)
- call disp_byt8(title, x, SE)
- end subroutine disp_tm_byt8
+ CALL disp_byt8(title, x, SE)
+END SUBROUTINE disp_tm_byt8
- subroutine disp_byt8(title, x, SE)
- ! 8-byte integer item
- character(*), intent(in) :: title
- integer(byt8), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- call find_editdesc_byt8(x, SE, wid, nbl) ! determine also SE%w
- call tobox_byt8(title, x, SE, wid, nbl)
- end subroutine disp_byt8
+SUBROUTINE disp_byt8(title, x, SE)
+ ! 8-byte integer item
+ CHARACTER(*), INTENT(in) :: title
+ INTEGER(byt8), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ CALL find_editdesc_byt8(x, SE, wid, nbl) ! determine also SE%w
+ CALL tobox_byt8(title, x, SE, wid, nbl)
+END SUBROUTINE disp_byt8
- subroutine tobox_byt8(title, x, SE, wid, nbl)
- ! Write 8-byte integer matrix to box
- character(*), intent(in) :: title
- integer(byt8), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(INOUT ) :: wid(:)
- integer, intent(INOUT ) :: nbl(:)
- character(SE%w) :: s(size(x,1))
- integer :: lin1, j, wleft, m, n, widp(size(wid))
- character, pointer :: boxp(:,:)
- m = size(x,1)
- n = size(x,2)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) x(:,j)
- if (SE%lzas > 0) call replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:,j) == 0)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j 0) WRITE (s, SE%ed) x(:, j)
+ IF (SE%lzas > 0) CALL replace_zeronaninf(s, SE%zas(1:SE%lzas), x(:, j) == 0)
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_byt8
- subroutine find_editdesc_byt8(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid
- integer(byt8), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(out) :: wid(size(x,2)), nbl(size(x,2))
- !
- integer(byt8) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm
- logical xzero(size(x,2)), xallz(size(x,2))
- character(22) s
- integer ww
- !
- if (SE%w == 0) then
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- SE%w = max(SE%lzas, ww)
- call replace_w(SE%ed, ww)
- elseif (SE%w < 0) then ! obtain max-width of x
- if (size(x) == 0) then
- SE%ed = '()'
- SE%w = 0
- wid = 0
- return
- endif
- xp = maxval(x)
- xm = minval(x)
- write(s, '(SS,I0)') xp; ww = len_trim(s)
- write(s, '(SS,I0)') xm; ww = max(ww, len_trim(s))
- ww = max(SE%lzas, ww)
- SE%ed = '(SS,Ixx)'
- write(SE%ed(6:7), '(SS,I2)') ww
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1) ! max in each column
- xminv = minval(x, 1) ! min
- xzero = any(x == 0_byt8, 1) ! true where column has some zeros
- xallz = all(x == 0_byt8, 1) ! true where column has only zeros
- call getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- else
- wid = SE%w
- nbl = 0
- endif
- end subroutine find_editdesc_byt8
+SUBROUTINE find_editdesc_byt8(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid
+ INTEGER(byt8), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ !
+ INTEGER(byt8) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm
+ LOGICAL xzero(SIZE(x, 2)), xallz(SIZE(x, 2))
+ CHARACTER(22) s
+ INTEGER ww
+ !
+ IF (SE%w == 0) THEN
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ SE%w = MAX(SE%lzas, ww)
+ CALL replace_w(SE%ed, ww)
+ ELSEIF (SE%w < 0) THEN ! obtain max-width of x
+ IF (SIZE(x) == 0) THEN
+ SE%ed = '()'
+ SE%w = 0
+ wid = 0
+ RETURN
+ END IF
+ xp = MAXVAL(x)
+ xm = MINVAL(x)
+ WRITE (s, '(SS,I0)') xp; ww = LEN_TRIM(s)
+ WRITE (s, '(SS,I0)') xm; ww = MAX(ww, LEN_TRIM(s))
+ ww = MAX(SE%lzas, ww)
+ SE%ed = '(SS,Ixx)'
+ WRITE (SE%ed(6:7), '(SS,I2)') ww
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1) ! max in each column
+ xminv = MINVAL(x, 1) ! min
+ xzero = ANY(x == 0_BYT8, 1) ! true where column has some zeros
+ xallz = ALL(x == 0_BYT8, 1) ! true where column has only zeros
+ CALL getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_byt8
- subroutine getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
- integer(byt8), intent(in) :: xmaxv(:), xminv(:)
- logical, intent(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
- type(settings), intent(in) :: SE ! Settings
- integer, intent(out) :: wid(:) ! Widths of columns
- integer, intent(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmax, SE%ed) xmaxv
- write(stmin, SE%ed) xminv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- wid = w - nbl
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- nbl = w - wid
- endif
- end subroutine getwid_byt8
+SUBROUTINE getwid_byt8(xmaxv, xminv, xzero, xallz, SE, wid, nbl)
+ INTEGER(byt8), INTENT(in) :: xmaxv(:), xminv(:)
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! True for columns with some/all zeros
+ TYPE(settings), INTENT(in) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(:) ! Widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! n of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmax, SE%ed) xmaxv
+ WRITE (stmin, SE%ed) xminv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ wid = w - nbl
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ nbl = w - wid
+ END IF
+END SUBROUTINE getwid_byt8
- ! ********* 8-BYTE INTEGER TOSTRING PROCEDURES *********
- function tostring_s_byt8(x) result(st)
- ! Scalar to string
- integer(byt8), intent(in) :: x
- character(len_f_byt8((/x/), tosset0%ifmt)) :: st
- st = tostring_f_byt8((/x/), tosset0%ifmt)
- end function tostring_s_byt8
+! ********* 8-BYTE INTEGER TOSTRING PROCEDURES *********
+FUNCTION tostring_s_byt8(x) RESULT(st)
+ ! Scalar to string
+ INTEGER(byt8), INTENT(in) :: x
+ CHARACTER(len_f_byt8((/x/), tosset0%ifmt)) :: st
+ st = tostring_f_byt8((/x/), tosset0%ifmt)
+END FUNCTION tostring_s_byt8
- function tostring_sf_byt8(x, fmt) result(st)
- ! Scalar with specified format to string
- integer(byt8),intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_byt8((/x/), fmt)) :: st
- st = tostring_f_byt8((/x/), fmt)
- end function tostring_sf_byt8
+FUNCTION tostring_sf_byt8(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ INTEGER(byt8), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byt8((/x/), fmt)) :: st
+ st = tostring_f_byt8((/x/), fmt)
+END FUNCTION tostring_sf_byt8
- function tostring_byt8(x) result(st)
- ! Vector to string
- integer(byt8), intent(in) :: x(:)
- character(len_f_byt8(x, tosset0%ifmt)) :: st
- st = tostring_f_byt8(x, tosset0%ifmt)
- end function tostring_byt8
+FUNCTION tostring_byt8(x) RESULT(st)
+ ! Vector to string
+ INTEGER(byt8), INTENT(in) :: x(:)
+ CHARACTER(len_f_byt8(x, tosset0%ifmt)) :: st
+ st = tostring_f_byt8(x, tosset0%ifmt)
+END FUNCTION tostring_byt8
- function tostring_f_byt8(x, fmt) result(st)
- ! Vector with specified format to string
- integer(byt8), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_byt8(x, fmt)) :: st
- character(widthmax_byt8(x, fmt)) :: sa(size(x))
- integer :: w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; st = errormsg; return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- call tostring_get(sa, st)
- end function tostring_f_byt8
+FUNCTION tostring_f_byt8(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ INTEGER(byt8), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_byt8(x, fmt)) :: st
+ CHARACTER(widthmax_byt8(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; st = errormsg; RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_byt8
- pure function len_f_byt8(x, fmt) result(wtot)
- ! Total width of tostring representation of x
- integer(byt8), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_byt8(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d
- logical :: gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- write(sa, fmt1) x
- if (tosset0%trimb == 'YES' .or. w == 0) sa = adjustl(sa)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_byt8
+PURE FUNCTION len_f_byt8(x, fmt) RESULT(wtot)
+ ! Total width of tostring representation of x
+ INTEGER(byt8), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_byt8(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES' .OR. w == 0) sa = ADJUSTL(sa)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_byt8
- pure function widthmax_byt8(x, fmt) result(w)
- ! Maximum width of string representation of an element in x
- integer(byt8), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(range(x)+2) sx(2)
- integer w, d
- logical gedit
- character(nnblk(fmt)+5) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w<=0) then
- write(sx, '(SS,I0)') maxval(x), minval(x)
- w = maxval(len_trim(sx))
- end if
- end function widthmax_byt8
- ! ************************************* END OF 8-BYTE INTEGER PROCEDURES ******************************************
+PURE FUNCTION widthmax_byt8(x, fmt) RESULT(w)
+ ! Maximum width of string representation of an element in x
+ INTEGER(byt8), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(RANGE(x) + 2) sx(2)
+ INTEGER w, d
+ LOGICAL gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) THEN
+ WRITE (sx, '(SS,I0)') MAXVAL(x), MINVAL(x)
+ w = MAXVAL(LEN_TRIM(sx))
+ END IF
+END FUNCTION widthmax_byt8
+! ************************************* END OF 8-BYTE INTEGER PROCEDURES ******************************************
END MODULE DISP_I8MOD
diff --git a/src/modules/Display/src/disp/disp_l1mod.F90 b/src/modules/Display/src/disp/disp_l1mod.F90
index ae1012cac..7e371961f 100755
--- a/src/modules/Display/src/disp/disp_l1mod.F90
+++ b/src/modules/Display/src/disp/disp_l1mod.F90
@@ -1,202 +1,202 @@
MODULE DISP_L1MOD
- ! Add-on module to DISPMODULE to display 1-byte logical items
- ! (assuming that these have kind = 1)
- !
- ! This module is obtained by copying the section DEFAULT LOGICAL PROCEDURES from
- ! dispmodule.F90, replacing dlog with log1 and 'default logical' with '1-byte
- ! logical' (only appears in comments), and adding the DECLARATIONS section below.
- !
- ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
- ! Iceland (jonasson@hi.is). This software is free. For details see the file README.
-
- use dispmodule_util
- USE GlobalData, ONLY: LGT
- PUBLIC DISP
- PUBLIC TOSTRING
-
- PRIVATE
-
- interface Display
+! Add-on module to DISPMODULE to display 1-byte logical items
+! (assuming that these have kind = 1)
+!
+! This module is obtained by copying the section DEFAULT LOGICAL PROCEDURES from
+! dispmodule.F90, replacing dlog with log1 and 'default logical' with '1-byte
+! logical' (only appears in comments), and adding the DECLARATIONS section below.
+!
+! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
+! Iceland (jonasson@hi.is). This software is free. For details see the file README.
+
+USE dispmodule_util
+USE GlobalData, ONLY: LGT
+PUBLIC DISP
+PUBLIC TOSTRING
+
+PRIVATE
+
+INTERFACE Display
module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1
- end interface
+END INTERFACE
- interface disp
+INTERFACE disp
module procedure disp_s_log1, disp_ts_log1, disp_v_log1, disp_tv_log1, disp_m_log1, disp_tm_log1
- end interface
+END INTERFACE
- interface tostring
+INTERFACE tostring
module procedure tostring_log1, tostring_f_log1, tostring_s_log1, tostring_sf_log1
- end interface
+END INTERFACE
- integer, parameter :: log1 = LGT ! hopefully logical(1) is byte
+INTEGER, PARAMETER :: log1 = LGT ! hopefully logical(1) is byte
CONTAINS
- ! ********************************************** 1-BYTE LOGICAL PROCEDURES *************************************************
- subroutine disp_s_log1(x, fmt, advance, sep, trim, unit)
- ! 1-byte logical scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim
- logical(log1), intent(in) :: x
- integer, intent(in), optional :: unit
- call disp_ts_log1('', x, fmt, advance, sep, 'left', trim, unit)
- end subroutine disp_s_log1
+! ********************************************** 1-BYTE LOGICAL PROCEDURES *************************************************
+SUBROUTINE disp_s_log1(x, fmt, advance, sep, trim, unit)
+ ! 1-byte logical scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim
+ LOGICAL(log1), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
+ CALL disp_ts_log1('', x, fmt, advance, sep, 'left', trim, unit)
+END SUBROUTINE disp_s_log1
subroutine disp_v_log1(x, fmt, advance, lbound, sep, style, trim, unit, orient)
- ! 1-byte logical vector without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient
- logical(log1), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tv_log1('', x, fmt, advance, lbound, sep, style, trim, unit, orient)
- end subroutine disp_v_log1
-
- subroutine disp_m_log1(x, fmt, advance, lbound, sep, style, trim, unit)
- ! 1-byte logical matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim
- logical(log1), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, lbound(:)
- call disp_tm_log1('', x, fmt, advance, lbound, sep, style, trim, unit)
- end subroutine disp_m_log1
-
- subroutine disp_ts_log1(title, x, fmt, advance, sep, style, trim, unit)
- ! 1-byte logical scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim
- logical(log1), intent(in) :: x
- integer, intent(in), optional :: unit
+ ! 1-byte logical vector without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient
+ LOGICAL(log1), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+CALL disp_tv_log1('', x, fmt, advance, lbound, sep, style, trim, unit, orient)
+END SUBROUTINE disp_v_log1
+
+SUBROUTINE disp_m_log1(x, fmt, advance, lbound, sep, style, trim, unit)
+ ! 1-byte logical matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim
+ LOGICAL(log1), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ CALL disp_tm_log1('', x, fmt, advance, lbound, sep, style, trim, unit)
+END SUBROUTINE disp_m_log1
+
+SUBROUTINE disp_ts_log1(title, x, fmt, advance, sep, style, trim, unit)
+ ! 1-byte logical scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim
+ LOGICAL(log1), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit
call disp_tm_log1(title, reshape((/x/), (/1, 1/)), fmt, advance, sep=sep, style=style, trim=trim, unit=unit)
- end subroutine disp_ts_log1
+END SUBROUTINE disp_ts_log1
subroutine disp_tv_log1(title, x, fmt, advance, lbound, sep, style, trim, unit, orient)
- ! 1-byte logical vector with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, orient
- logical(log1), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:)
- type(settings) :: SE
+ ! 1-byte logical vector with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, orient
+ LOGICAL(log1), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:)
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient)
- if (SE%row) then
- call disp_log1(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_log1(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_log1
+ IF (SE%row) THEN
+ CALL disp_log1(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_log1(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_log1
subroutine disp_tm_log1(title, x, fmt, advance, lbound, sep, style, trim, unit)
- ! 1-byte logical matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- logical(log1),intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Format edit descriptor to use for each matrix element (e.g. 'L1')
- integer, intent(in), optional :: unit ! Unit to display on
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no trimming,
- ! ! 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
- !
- call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit)
- call disp_log1(title, x, SE)
- end subroutine disp_tm_log1
-
- subroutine disp_log1(title, x, SE)
- ! Write 1-byte logical to box or unit
- character(*), intent(in) :: title
- logical(log1), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- if (SE%w <= 0 .or. SE%trm) then
- SE%ed = '(L1)'
- if (size(x) == 0) then
- wid = 0
- else
- wid = 1
- endif
- SE%w = 1
- nbl = SE%w - wid
- else
- wid = SE%w
- nbl = 0
- endif
- call tobox_log1(title, x, SE, wid, nbl)
- end subroutine disp_log1
-
- subroutine tobox_log1(title, x, SE, wid, nbl)
- character(*), intent(in) :: title
- logical(log1), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer, intent(INOUT ) :: wid(:)
- integer, intent(INOUT ) :: nbl(:)
- character(SE%w) :: s(size(x,1))
- integer :: m, n, lin1, i, j, wleft, widp(size(wid))
- character, pointer :: boxp(:,:)
- m = size(x,1)
- n = size(x,2)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) (x(i,j), i=1,m)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j 0) WRITE (s, SE%ed) (x(i, j), i=1, m)
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_log1
+
+! ********** 1-BYTE LOGICAL TOSTRING PROCEDURES *********
+FUNCTION tostring_s_log1(x) RESULT(st)
+ LOGICAL(log1), INTENT(in) :: x
+ CHARACTER(1) :: st
+ st = tostring_f_log1((/x/), 'L1')
+END FUNCTION tostring_s_log1
+
+FUNCTION tostring_sf_log1(x, fmt) RESULT(st)
+ LOGICAL(log1), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_log1((/x/), fmt)) :: st
+ st = tostring_f_log1((/x/), fmt)
+END FUNCTION tostring_sf_log1
+
+FUNCTION tostring_log1(x) RESULT(st)
+ LOGICAL(log1), INTENT(in) :: x(:)
+ CHARACTER(1 + (SIZE(x) - 1)*(1 + tosset0%seplen)) :: st
+ st = tostring_f_log1(x, 'L1')
+END FUNCTION tostring_log1
+
+FUNCTION tostring_f_log1(x, fmt) RESULT(st)
+ LOGICAL(log1), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_log1(x, fmt)) :: st
+ CHARACTER(widthmax_log1(fmt)) :: sa(SIZE(x))
+ INTEGER :: w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 2) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) THEN; st = errormsg; RETURN; END IF
+ WRITE (sa, fmt1) x
+ IF (tosset0%trimb == 'YES') sa = ADJUSTL(sa)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_log1
+
+PURE FUNCTION len_f_log1(x, fmt) RESULT(wtot)
+ LOGICAL(log1), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 2) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ IF (tosset0%trimb == 'YES') wtot = SIZE(x)
+ IF (tosset0%trimb == 'NO') wtot = w * SIZE(x)
+ wtot = wtot + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_log1
+
+PURE FUNCTION widthmax_log1(fmt) RESULT(w)
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER w, d
+ LOGICAL gedit
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w <= 0) w = 1
+END FUNCTION widthmax_log1
END MODULE DISP_L1MOD
diff --git a/src/modules/Display/src/disp/disp_r16mod.F90 b/src/modules/Display/src/disp/disp_r16mod.F90
index bd2b36fd0..0917be0b1 100755
--- a/src/modules/Display/src/disp/disp_r16mod.F90
+++ b/src/modules/Display/src/disp/disp_r16mod.F90
@@ -1,553 +1,553 @@
MODULE DISP_R16MOD
#ifdef USE_Real128
- ! Add-on module to DISPMODULE to display selected_real_kind(25) reals
- ! (these are probably 16 bytes and possibly quadruple precision)
- !
- ! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from
- ! dispmodule.F90, replacing sngl with quad, single withe quadruple (only appears
- ! in comments) and cplx with cplq, adding a DECLARATIONS section, and defining
- ! the constant quad as selected_real_kind(25).
- !
- ! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
- ! Iceland (jonasson@hi.is). This software is free. For details see the file README.
-
- ! ******************************** DECLARATIONS ********************************************
- use dispmodule_util
- USE GlobalData, ONLY: Real128
- PUBLIC DISP
- PUBLIC TOSTRING
-
- PRIVATE
-
- interface Display
+! Add-on module to DISPMODULE to display selected_real_kind(25) reals
+! (these are probably 16 bytes and possibly quadruple precision)
+!
+! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from
+! dispmodule.F90, replacing sngl with quad, single withe quadruple (only appears
+! in comments) and cplx with cplq, adding a DECLARATIONS section, and defining
+! the constant quad as selected_real_kind(25).
+!
+! Copyright (c) 2008, Kristj�n J�nasson, Dept. of Computer Science, University of
+! Iceland (jonasson@hi.is). This software is free. For details see the file README.
+
+! ******************************** DECLARATIONS ********************************************
+USE dispmodule_util
+USE GlobalData, ONLY: REAL128
+PUBLIC DISP
+PUBLIC TOSTRING
+
+PRIVATE
+
+INTERFACE Display
module procedure disp_s_quad, disp_ts_quad, disp_v_quad, disp_tv_quad, disp_m_quad, disp_tm_quad
module procedure disp_s_cplq, disp_ts_cplq, disp_v_cplq, disp_tv_cplq, disp_m_cplq, disp_tm_cplq
- end interface
+END INTERFACE
- interface disp
+INTERFACE disp
module procedure disp_s_quad, disp_ts_quad, disp_v_quad, disp_tv_quad, disp_m_quad, disp_tm_quad
module procedure disp_s_cplq, disp_ts_cplq, disp_v_cplq, disp_tv_cplq, disp_m_cplq, disp_tm_cplq
- end interface
+END INTERFACE
- interface tostring
+INTERFACE tostring
module procedure tostring_quad, tostring_f_quad, tostring_s_quad, tostring_sf_quad
module procedure tostring_cplq, tostring_f_cplq, tostring_s_cplq, tostring_sf_cplq
- end interface
+END INTERFACE
- integer, parameter :: quad = Real128
+INTEGER, PARAMETER :: quad = REAL128
CONTAINS
- ! **************************** QUADRUPLE PRECISION PROCEDURES *******************************
- subroutine disp_s_quad(x, fmt, advance, digmax, sep, trim, unit, zeroas)
- ! quadruple precision scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
- real(quad), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+! **************************** QUADRUPLE PRECISION PROCEDURES *******************************
+SUBROUTINE disp_s_quad(x, fmt, advance, digmax, sep, trim, unit, zeroas)
+ ! quadruple precision scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas
+ REAL(quad), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_ts_quad('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas)
- end subroutine disp_s_quad
+END SUBROUTINE disp_s_quad
subroutine disp_v_quad(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- ! quadruple precision vector without title
+ ! quadruple precision vector without title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- real(quad), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
+ REAL(quad), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
call disp_tv_quad('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- end subroutine disp_v_quad
+END SUBROUTINE disp_v_quad
subroutine disp_m_quad(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas)
- ! quadruple precision matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- real(quad), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, digmax, lbound(:)
+ ! quadruple precision matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ REAL(quad), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:)
call disp_tm_quad('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
- end subroutine disp_m_quad
+END SUBROUTINE disp_m_quad
subroutine disp_ts_quad(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas)
- ! quadruple precision scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- real(quad), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ ! quadruple precision scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ REAL(quad), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_tm_quad(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, &
- unit=unit, zeroas=zeroas)
- end subroutine disp_ts_quad
+ unit=unit, zeroas=zeroas)
+END SUBROUTINE disp_ts_quad
subroutine disp_tv_quad(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- ! quadruple precision vector with title
- character(*), intent(in) :: title
+ ! quadruple precision vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- real(quad), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
- type(settings) :: SE
+ REAL(quad), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax)
- if (SE%row) then
- call disp_quad(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_quad(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_quad
+ IF (SE%row) THEN
+ CALL disp_quad(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_quad(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_quad
subroutine disp_tm_quad(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
- ! quadruple precision matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- real(quad), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
- integer, intent(in), optional :: unit ! Unit to display on
- integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in x
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: zeroas ! Zeros are replaced with this string if it is not empty
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
- !
+ ! quadruple precision matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ REAL(quad), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in x
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced with this string if it is not empty
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ TYPE(settings) :: SE
+ !
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax)
- call disp_quad(title, x, SE)
- end subroutine disp_tm_quad
-
- subroutine disp_quad(title, x, SE)
- ! quadruple precision item
- character(*), intent(in) :: title
- real(quad), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- call find_editdesc_quad(x, SE, wid, nbl) ! determine also SE%w
- call tobox_quad(title, x, SE, wid, nbl)
- end subroutine disp_quad
-
- subroutine tobox_quad(title, x, SE, wid, nbl)
- ! Write quadruple precision matrix to box
- character(*), intent(in) :: title ! title
- real(quad), intent(in) :: x(:,:) ! item
- type(settings), intent(INOUT ) :: SE ! settings
- integer, intent(INOUT ) :: wid(:) ! widths of columns
- integer, intent(INOUT ) :: nbl(:) ! number of blanks to trim from left
- character(SE%w) :: s(size(x,1))
- integer :: lin1, j, wleft, m, n, widp(size(wid))
- character, pointer :: boxp(:,:)
- real(quad) :: xj(size(x,1)), h
- m = size(x,1)
- n = size(x,2)
- h = huge(x)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- xj = x(:, j)
- if (m > 0) write(s, SE%ed) xj
+ CALL disp_quad(title, x, SE)
+END SUBROUTINE disp_tm_quad
+
+SUBROUTINE disp_quad(title, x, SE)
+ ! quadruple precision item
+ CHARACTER(*), INTENT(in) :: title
+ REAL(quad), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ CALL find_editdesc_quad(x, SE, wid, nbl) ! determine also SE%w
+ CALL tobox_quad(title, x, SE, wid, nbl)
+END SUBROUTINE disp_quad
+
+SUBROUTINE tobox_quad(title, x, SE, wid, nbl)
+ ! Write quadruple precision matrix to box
+ CHARACTER(*), INTENT(in) :: title ! title
+ REAL(quad), INTENT(in) :: x(:, :) ! item
+ TYPE(settings), INTENT(INOUT) :: SE ! settings
+ INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns
+ INTEGER, INTENT(INOUT) :: nbl(:) ! number of blanks to trim from left
+ CHARACTER(SE%w) :: s(SIZE(x, 1))
+ INTEGER :: lin1, j, wleft, m, n, widp(SIZE(wid))
+ CHARACTER, POINTER :: boxp(:, :)
+ REAL(quad) :: xj(SIZE(x, 1)), h
+ m = SIZE(x, 1)
+ n = SIZE(x, 2)
+ h = HUGE(x)
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ xj = x(:, j)
+ IF (m > 0) WRITE (s, SE%ed) xj
call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf
- if (.not. any(xfinite)) then
- w = 4
- else
- xmax = maxval(x, mask=xfinite)
- xmin = minval(x, mask=xfinite)
- f1 = '(SS,ES9.0E4)'
- write(s,f1) xmax, xmin
- read(s(:)(5:9),'(I5)') expmax, expmin
- w = max(0, expmax, expmin) + d + 4
- end if
- if (.not. all(xfinite)) w = max(w, 4)
- end function maxw_quad
-
- subroutine find_editdesc_quad(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid.
- ! The if-block (*) is for safety: make f wider in case xm is written ok with the
- ! ES format in fmt but overflows with F format (the feature has been tested through
- ! manual changes to the program).
- real(quad), intent(in) :: x(:,:) ! Item to be written
- type(settings), intent(INOUT ) :: SE ! Settings
- integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns
- integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns
- integer :: expmax, expmin, ww, dd, dmx
- real(quad) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h
- character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4
- character(99) s
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_quad
+
+PURE FUNCTION maxw_quad(x, d) RESULT(w)
+ ! Find max field width needed (F0.d editing is specified)
+ REAL(quad), INTENT(in) :: x(:)
+ INTEGER, INTENT(in) :: d
+ INTEGER expmax, expmin, w
+ LOGICAL xfinite(SIZE(x))
+ REAL(quad) xmax, xmin, h
+ CHARACTER(12) :: f1, s(2)
+ xmin = 0; xmax = 0; h = HUGE(h)
+ xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf
+ IF (.NOT. ANY(xfinite)) THEN
+ w = 4
+ ELSE
+ xmax = MAXVAL(x, mask=xfinite)
+ xmin = MINVAL(x, mask=xfinite)
+ f1 = '(SS,ES9.0E4)'
+ WRITE (s, f1) xmax, xmin
+ READ (s(:) (5:9), '(I5)') expmax, expmin
+ w = MAX(0, expmax, expmin) + d + 4
+ END IF
+ IF (.NOT. ALL(xfinite)) w = MAX(w, 4)
+END FUNCTION maxw_quad
+
+SUBROUTINE find_editdesc_quad(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid.
+ ! The if-block (*) is for safety: make f wider in case xm is written ok with the
+ ! ES format in fmt but overflows with F format (the feature has been tested through
+ ! manual changes to the program).
+ REAL(quad), INTENT(in) :: x(:, :) ! Item to be written
+ TYPE(settings), INTENT(INOUT) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)) ! Widths of individual columns
+ INTEGER, INTENT(out) :: nbl(SIZE(x, 2)) ! Blanks to trim from left of individual columns
+ INTEGER :: expmax, expmin, ww, dd, dmx
+ REAL(quad) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm, h
+ CHARACTER(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4
+ CHARACTER(99) s
logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2))
- !
- dmx = SE%dmx
- h = huge(h)
- xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf
- if (SE%w == 0) then ! Edit descriptor 'F0.d' specified
- ww = maxw_quad(reshape(x, (/size(x)/)), SE%d)
- if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas)
- call replace_w(SE%ed, ww)
- SE%w = ww
- elseif (SE%w < 0) then ! No edit descriptor specified
- if (size(x) == 0) then
- SE%w = 0
- wid = 0
- nbl = 0
- return
- endif
- if (any(xfinite)) then
- xp = maxval(x, mask=xfinite)
- xm = minval(x, mask=xfinite)
- write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
- write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax
- write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin
- call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0)
- if (.not. all(xfinite)) ww = max(ww, 4)
- if (SE%lzas > 0 .and. any(x == 0._quad)) ww = max(ww, SE%lzas)
- if (SE%ed(5:5)=='F') then ! (*)
- write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1
- write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1
- write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd
- endif
- else
- ww = 4
- SE%ed = '(F4.0)'
- endif
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1, mask=xfinite) ! max in each column
- xminv = minval(x, 1, mask=xfinite) ! min
- xzero = any(x == 0._quad, 1) ! true where column has some zeros
- xallz = all(x == 0._quad, 1) ! true where column has only zeros
- xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan)
- xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan)
- call getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
- else
- wid = SE%w
+ !
+ dmx = SE%dmx
+ h = HUGE(h)
+ xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf
+ IF (SE%w == 0) THEN ! Edit descriptor 'F0.d' specified
+ ww = maxw_quad(RESHAPE(x, (/SIZE(x)/)), SE%d)
+ IF (SE%lzas > 0 .AND. ANY(x == 0._QUAD)) ww = MAX(ww, SE%lzas)
+ CALL replace_w(SE%ed, ww)
+ SE%w = ww
+ ELSEIF (SE%w < 0) THEN ! No edit descriptor specified
+ IF (SIZE(x) == 0) THEN
+ SE%w = 0
+ wid = 0
nbl = 0
- endif
- end subroutine find_editdesc_quad
-
- subroutine getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
- ! determine length of the strings that result when writing with edit descriptor SE%ed a
- ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
- real(quad), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column
- logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros
- logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
- type(settings), intent(in) :: SE ! settings
- integer, intent(out) :: wid(:) ! widths of columns
- integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmin, SE%ed) xminv
- write(stmax, SE%ed) xmaxv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- if (SE%gedit) then
- wid = w
- else
- wid = len_trim(adjustl(stmin))
- wid = max(wid, len_trim(adjustl(stmax)))
- endif
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- endif
- wid = merge(4, wid, xalln)
- wid = max(wid, merge(4, 0, xnonn))
- nbl = w - wid
- end subroutine getwid_quad
-
- ! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES ***********
- function tostring_s_quad(x) result(st)
- ! Scalar to string
- real(quad), intent(in) :: x
- character(len_f_quad((/x/), tosset0%rfmt)) :: st
- st = tostring_f_quad((/x/), tosset0%rfmt)
- end function tostring_s_quad
-
- function tostring_sf_quad(x, fmt) result(st)
- ! Scalar with specified format to string
- real(quad), intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_quad((/x/), fmt)) :: st
- st = tostring_f_quad((/x/), fmt)
- end function tostring_sf_quad
-
- function tostring_quad(x) result(st)
- ! Vector to string
- real(quad), intent(in) :: x(:)
- character(len_f_quad(x, tosset0%rfmt)) :: st
- st = tostring_f_quad(x, tosset0%rfmt)
- end function tostring_quad
-
- function tostring_f_quad(x, fmt) result(st)
- ! Vector with specified format to string
- real(quad) , intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_quad(x, fmt)) :: st
- character(widthmax_quad(x, fmt)) :: sa(size(x))
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- integer :: w, d, ww
- logical :: gedit
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then
- st = errormsg
- return
- elseif (w == 0) then
- ww = maxw_quad(x, d)
- call replace_w(fmt1, ww)
- endif
- write(sa, fmt1) x
- call trim_real(sa, gedit, w)
- call tostring_get(sa, st)
- end function tostring_f_quad
-
- pure function len_f_quad(x, fmt) result(wtot)
- ! Total length of returned string, vector s
- real(quad), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_quad(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d, ww
- logical :: gedit
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- if (w == 0) then
- ww = maxw_quad(x, d)
- call replace_w(fmt1, ww)
- endif
- write(sa, fmt1) x
- call trim_real(sa, gedit, w)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_quad
-
- pure function widthmax_quad(x, fmt) result(w)
- ! Maximum width of an element of x
- real(quad), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(nnblk(fmt)+5) :: fmt1
- integer w, d
- logical gedit
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then ! illegal format, use 1
- w = 1
- elseif (w == 0) then
- w = maxw_quad(x, d)
- endif
- end function widthmax_quad
-
- ! *************************************** END OF QUADRUPLE PRECISION PROCEDURES ***************************************
-
- ! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES **************************************
- subroutine disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
- ! quadruple precision complex scalar without title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim
- complex(quad), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ RETURN
+ END IF
+ IF (ANY(xfinite)) THEN
+ xp = MAXVAL(x, mask=xfinite)
+ xm = MINVAL(x, mask=xfinite)
+ WRITE (f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
+ WRITE (s, f1) xp; READ (s(dmx + 4:dmx + 8), '(I5)') expmax
+ WRITE (s, f1) xm; READ (s(dmx + 4:dmx + 8), '(I5)') expmin
+ CALL find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0)
+ IF (.NOT. ALL(xfinite)) ww = MAX(ww, 4)
+ IF (SE%lzas > 0 .AND. ANY(x == 0._QUAD)) ww = MAX(ww, SE%lzas)
+ IF (SE%ed(5:5) == 'F') THEN ! (*)
+ WRITE (s, SE%ed) xp; IF (s(1:1) == '*') ww = ww + 1
+ WRITE (s, SE%ed) xm; IF (s(1:1) == '*') ww = ww + 1
+ WRITE (SE%ed(6:10), '(SS,I2,".",I2)') ww, dd
+ END IF
+ ELSE
+ ww = 4
+ SE%ed = '(F4.0)'
+ END IF
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1, mask=xfinite) ! max in each column
+ xminv = MINVAL(x, 1, mask=xfinite) ! min
+ xzero = ANY(x == 0._QUAD, 1) ! true where column has some zeros
+ xallz = ALL(x == 0._QUAD, 1) ! true where column has only zeros
+ xnonn = ANY(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan)
+ xalln = ALL(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan)
+ CALL getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_quad
+
+SUBROUTINE getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
+ ! determine length of the strings that result when writing with edit descriptor SE%ed a
+ ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
+ REAL(quad), INTENT(in) :: xmaxv(:), xminv(:) ! max and min values in each column
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros
+ LOGICAL, INTENT(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
+ TYPE(settings), INTENT(in) :: SE ! settings
+ INTEGER, INTENT(out) :: wid(:) ! widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! number of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmin, SE%ed) xminv
+ WRITE (stmax, SE%ed) xmaxv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ IF (SE%gedit) THEN
+ wid = w
+ ELSE
+ wid = LEN_TRIM(ADJUSTL(stmin))
+ wid = MAX(wid, LEN_TRIM(ADJUSTL(stmax)))
+ END IF
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ END IF
+ wid = MERGE(4, wid, xalln)
+ wid = MAX(wid, MERGE(4, 0, xnonn))
+ nbl = w - wid
+END SUBROUTINE getwid_quad
+
+! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES ***********
+FUNCTION tostring_s_quad(x) RESULT(st)
+ ! Scalar to string
+ REAL(quad), INTENT(in) :: x
+ CHARACTER(len_f_quad((/x/), tosset0%rfmt)) :: st
+ st = tostring_f_quad((/x/), tosset0%rfmt)
+END FUNCTION tostring_s_quad
+
+FUNCTION tostring_sf_quad(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ REAL(quad), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_quad((/x/), fmt)) :: st
+ st = tostring_f_quad((/x/), fmt)
+END FUNCTION tostring_sf_quad
+
+FUNCTION tostring_quad(x) RESULT(st)
+ ! Vector to string
+ REAL(quad), INTENT(in) :: x(:)
+ CHARACTER(len_f_quad(x, tosset0%rfmt)) :: st
+ st = tostring_f_quad(x, tosset0%rfmt)
+END FUNCTION tostring_quad
+
+FUNCTION tostring_f_quad(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ REAL(quad), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_quad(x, fmt)) :: st
+ CHARACTER(widthmax_quad(x, fmt)) :: sa(SIZE(x))
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ INTEGER :: w, d, ww
+ LOGICAL :: gedit
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN
+ st = errormsg
+ RETURN
+ ELSEIF (w == 0) THEN
+ ww = maxw_quad(x, d)
+ CALL replace_w(fmt1, ww)
+ END IF
+ WRITE (sa, fmt1) x
+ CALL trim_real(sa, gedit, w)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_quad
+
+PURE FUNCTION len_f_quad(x, fmt) RESULT(wtot)
+ ! Total length of returned string, vector s
+ REAL(quad), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_quad(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d, ww
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ IF (w == 0) THEN
+ ww = maxw_quad(x, d)
+ CALL replace_w(fmt1, ww)
+ END IF
+ WRITE (sa, fmt1) x
+ CALL trim_real(sa, gedit, w)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_quad
+
+PURE FUNCTION widthmax_quad(x, fmt) RESULT(w)
+ ! Maximum width of an element of x
+ REAL(quad), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ INTEGER w, d
+ LOGICAL gedit
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN ! illegal format, use 1
+ w = 1
+ ELSEIF (w == 0) THEN
+ w = maxw_quad(x, d)
+ END IF
+END FUNCTION widthmax_quad
+
+! *************************************** END OF QUADRUPLE PRECISION PROCEDURES ***************************************
+
+! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES **************************************
+SUBROUTINE disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
+ ! quadruple precision complex scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, trim
+ COMPLEX(quad), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_ts_cplq('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit)
- end subroutine disp_s_cplq
+END SUBROUTINE disp_s_cplq
subroutine disp_v_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- ! quadruple precision complex vector without title
+ ! quadruple precision complex vector without title
character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
- complex(quad), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
+ COMPLEX(quad), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
call disp_tv_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- end subroutine disp_v_cplq
+END SUBROUTINE disp_v_cplq
subroutine disp_m_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- ! quadruple precision complex matrix without title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
- complex(quad), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, digmax, lbound(:)
+ ! quadruple precision complex matrix without title
+CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim
+ COMPLEX(quad), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:)
call disp_tm_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- end subroutine disp_m_cplq
+END SUBROUTINE disp_m_cplq
subroutine disp_ts_cplq(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit)
- ! quadruple precision complex scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
- complex(quad), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ ! quadruple precision complex scalar with title
+ CHARACTER(*), INTENT(in) :: title
+CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim
+ COMPLEX(quad), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_tm_cplq(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, &
- trim=trim, unit=unit)
- end subroutine disp_ts_cplq
+ trim=trim, unit=unit)
+END SUBROUTINE disp_ts_cplq
subroutine disp_tv_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- ! quadruple precision complex vector with title
- character(*), intent(in) :: title
+ ! quadruple precision complex vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
- complex(quad), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
- type(settings) SE, SEim
+ COMPLEX(quad), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
+ TYPE(settings) SE, SEim
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax)
- if (present(fmt_imag)) then
- if (.not.present(fmt)) then
- call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return;
- endif
- call get_SE(SEim, title, shape(x), fmt_imag)
- else
- SEim = SE
- end if
- if (SE%row) then
- call disp_cplq(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x))
- else
- call disp_cplq(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1)
- end if
- end subroutine disp_tv_cplq
+ IF (PRESENT(fmt_imag)) THEN
+ IF (.NOT. PRESENT(fmt)) THEN
+ CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN;
+ END IF
+ CALL get_SE(SEim, title, SHAPE(x), fmt_imag)
+ ELSE
+ SEim = SE
+ END IF
+ IF (SE%row) THEN
+ CALL disp_cplq(title, RESHAPE(x, (/1, SIZE(x)/)), SE, SEim, n=SIZE(x))
+ ELSE
+ CALL disp_cplq(title, RESHAPE(x, (/SIZE(x), 1/)), SE, SEim, n=1)
+ END IF
+END SUBROUTINE disp_tv_cplq
subroutine disp_tm_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- ! quadruple precision complex matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- complex(quad), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag &
- ! ! is present)
- character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element
- integer, intent(in), optional :: unit ! Unit to display on
- integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) &
- ! ! and aimag(x)
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- !
- type(settings) :: SE, SEim
+ ! quadruple precision complex matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ COMPLEX(quad), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Edit descriptor for each element (real element when fmt_imag &
+ ! ! is present)
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt_imag ! Edit descriptor for each imaginary element
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in real(x) &
+ ! ! and aimag(x)
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ !
+ TYPE(settings) :: SE, SEim
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax)
- if (present(fmt_imag)) then
- if (.not.present(fmt)) then
- call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return
- endif
- call get_SE(SEim, title, shape(x), fmt_imag)
- else
- SEim = SE
- end if
- call disp_cplq(title, x, SE, SEim, n = size(x,2))
- end subroutine disp_tm_cplq
-
- subroutine disp_cplq(title, x, SE, SEim, n)
- ! quadruple precision item
- character(*), intent(in) :: title
- complex(quad), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE, SEim
- integer, intent(in) :: n
- integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n)
- call find_editdesc_quad(real(x), SE, widre, nblre) ! determine also SE%w
- call find_editdesc_quad(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w
+ IF (PRESENT(fmt_imag)) THEN
+ IF (.NOT. PRESENT(fmt)) THEN
+ CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN
+ END IF
+ CALL get_SE(SEim, title, SHAPE(x), fmt_imag)
+ ELSE
+ SEim = SE
+ END IF
+ CALL disp_cplq(title, x, SE, SEim, n=SIZE(x, 2))
+END SUBROUTINE disp_tm_cplq
+
+SUBROUTINE disp_cplq(title, x, SE, SEim, n)
+ ! quadruple precision item
+ CHARACTER(*), INTENT(in) :: title
+ COMPLEX(quad), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE, SEim
+ INTEGER, INTENT(in) :: n
+ INTEGER, DIMENSION(n) :: widre(n), widim(n), nblre(n), nblim(n)
+ CALL find_editdesc_quad(REAL(x), SE, widre, nblre) ! determine also SE%w
+ CALL find_editdesc_quad(ABS(AIMAG(x)), SEim, widim, nblim) ! determine also SEim%w
call tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2))
- end subroutine disp_cplq
-
- subroutine tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
- ! Write quadruple precision complex matrix to box
- character(*), intent(in) :: title
- complex(quad), intent(in) :: x(:,:)
- integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:)
- type(settings), intent(INOUT ) :: SE, SEim
- character(SE%w) :: s(m)
- character(SEim%w) :: sim(m)
- character(3) :: sgn(m)
- integer :: lin1, i, j, wleft, wid(n), widp(n)
- character, pointer :: boxp(:,:)
- SE%zas = ''
- SEim%zas = ''
- wid = widre + widim + 4
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m)
+END SUBROUTINE disp_cplq
+
+SUBROUTINE tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
+ ! Write quadruple precision complex matrix to box
+ CHARACTER(*), INTENT(in) :: title
+ COMPLEX(quad), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:)
+ TYPE(settings), INTENT(INOUT) :: SE, SEim
+ CHARACTER(SE%w) :: s(m)
+ CHARACTER(SEim%w) :: sim(m)
+ CHARACTER(3) :: sgn(m)
+ INTEGER :: lin1, i, j, wleft, wid(n), widp(n)
+ CHARACTER, POINTER :: boxp(:, :)
+ SE%zas = ''
+ SEim%zas = ''
+ wid = widre + widim + 4
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ IF (m > 0) WRITE (s, SE%ed) (REAL(x(i, j)), i=1, m)
call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft)
- do i=1,m
- if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif
- enddo
- call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft)
- if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m)
- call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft)
- call copyseptobox('i', m, lin1, boxp, wleft)
- if (j 0) WRITE (sim, SEim%ed) (ABS(AIMAG(x(i, j))), i=1, m)
+ CALL copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft)
+ CALL copyseptobox('i', m, lin1, boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_cplq
+
+! ******* TOSTRING QUADRUPLE PRECISION COMPLEX PROCEDURES ********
+
+FUNCTION tostring_s_cplq(x) RESULT(st)
+ COMPLEX(quad), INTENT(in) :: x
+ CHARACTER(len_s_cplq(x, tosset0%rfmt)) :: st
+ st = tostring_f_cplq((/x/), tosset0%rfmt)
+END FUNCTION tostring_s_cplq
+
+FUNCTION tostring_sf_cplq(x, fmt) RESULT(st)
+ COMPLEX(quad), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_s_cplq(x, fmt)) :: st
+ st = tostring_f_cplq((/x/), fmt)
+END FUNCTION tostring_sf_cplq
+
+FUNCTION tostring_cplq(x) RESULT(st)
+ COMPLEX(quad), INTENT(in) :: x(:)
+ CHARACTER(len_f_cplq(x, tosset0%rfmt)) :: st
+ st = tostring_f_cplq(x, tosset0%rfmt)
+END FUNCTION tostring_cplq
+
+FUNCTION tostring_f_cplq(x, fmt) RESULT(st)
+ COMPLEX(quad), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_cplq(x, fmt)) :: st
+ CHARACTER(widthmax_quad(REAL(x), fmt)) :: sar(SIZE(x))
+ CHARACTER(widthmax_quad(ABS(x - REAL(x)), fmt)) :: sai(SIZE(x)) ! x-real(x) instead of aimag(x) to enable the fnction
+ CHARACTER(1) :: sgn(SIZE(x)) ! to pass -stand:f95 switch of the ifort compiler.
+ INTEGER :: w, d, wr, wi, i
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ REAL(quad) :: xre(SIZE(x)), xim(SIZE(x)), h
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ xre = REAL(x)
+ xim = AIMAG(x)
+ h = HUGE(h)
+ IF (w < 0) THEN
+ st = errormsg
+ RETURN
+ ELSEIF (w == 0) THEN
+ wr = maxw_quad(xre, d)
+ wi = maxw_quad(xim, d)
+ CALL replace_w(fmt1, MAX(wr, wi))
+ END IF
+ WRITE (sar, fmt1) REAL(x)
+ WRITE (sai, fmt1) ABS(AIMAG(x))
+ CALL trim_real(sar, gedit, w)
+ CALL trim_real(sai, gedit, w)
+ DO i = 1, SIZE(x); IF (AIMAG(x(i)) < 0) THEN; sgn(i) = '-'; ELSE; sgn(i) = '+'; END IF; END DO
+ CALL tostring_get_complex(sar, sgn, sai, st)
+END FUNCTION tostring_f_cplq
+
+PURE FUNCTION len_s_cplq(x, fmt) RESULT(wtot)
+ COMPLEX(quad), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ wtot = len_f_quad((/REAL(x)/), fmt) + len_f_quad((/ABS(AIMAG(x))/), fmt) + 4
+END FUNCTION len_s_cplq
+
+PURE FUNCTION len_f_cplq(x, fmt) RESULT(wtot)
+ COMPLEX(quad), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
wtot = len_f_quad(real(x), fmt) + len_f_quad(abs(aimag(x)), fmt) + size(x)*4 - (size(x) - 1)*(tosset0%seplen)
- ! subtract seplen because it has been added twice in len_f_quad
- end function len_f_cplq
- ! *************************************** END OF QUADRUPLE PRECISION COMPLEX PROCEDURES ********************************
+ ! subtract seplen because it has been added twice in len_f_quad
+END FUNCTION len_f_cplq
+! *************************************** END OF QUADRUPLE PRECISION COMPLEX PROCEDURES ********************************
#endif
END MODULE DISP_R16MOD
diff --git a/src/modules/Display/src/disp/disp_r4mod.F90 b/src/modules/Display/src/disp/disp_r4mod.F90
index b816a007a..94b5deb3e 100755
--- a/src/modules/Display/src/disp/disp_r4mod.F90
+++ b/src/modules/Display/src/disp/disp_r4mod.F90
@@ -11,7 +11,7 @@
MODULE DISP_R4MOD
USE DISPMODULE_UTIL
-USE GlobalData, ONLY: Real32
+USE GlobalData, ONLY: REAL32
PUBLIC DISP
PUBLIC TOSTRING
PRIVATE
@@ -34,516 +34,516 @@ MODULE DISP_R4MOD
MODULE PROCEDURE tostring_cplx, tostring_f_cplx, tostring_s_cplx, tostring_sf_cplx
END INTERFACE TOSTRING
-INTEGER, PARAMETER :: sngl = Real32
+INTEGER, PARAMETER :: sngl = REAL32
CONTAINS
- subroutine disp_s_sngl(x, fmt, advance, digmax, sep, trim, unit, zeroas)
- ! snglruple precision scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
- real(sngl), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+SUBROUTINE disp_s_sngl(x, fmt, advance, digmax, sep, trim, unit, zeroas)
+ ! snglruple precision scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas
+ REAL(sngl), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_ts_sngl('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas)
- end subroutine disp_s_sngl
+END SUBROUTINE disp_s_sngl
subroutine disp_v_sngl(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- ! snglruple precision vector without title
+ ! snglruple precision vector without title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- real(sngl), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
+ REAL(sngl), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
call disp_tv_sngl('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- end subroutine disp_v_sngl
+END SUBROUTINE disp_v_sngl
subroutine disp_m_sngl(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas)
- ! snglruple precision matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- real(sngl), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, digmax, lbound(:)
+ ! snglruple precision matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ REAL(sngl), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:)
call disp_tm_sngl('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
- end subroutine disp_m_sngl
+END SUBROUTINE disp_m_sngl
subroutine disp_ts_sngl(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas)
- ! snglruple precision scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- real(sngl), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ ! snglruple precision scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ REAL(sngl), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_tm_sngl(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, &
- unit=unit, zeroas=zeroas)
- end subroutine disp_ts_sngl
+ unit=unit, zeroas=zeroas)
+END SUBROUTINE disp_ts_sngl
subroutine disp_tv_sngl(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- ! snglruple precision vector with title
- character(*), intent(in) :: title
+ ! snglruple precision vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- real(sngl), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
- type(settings) :: SE
+ REAL(sngl), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax)
- if (SE%row) then
- call disp_sngl(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_sngl(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_sngl
+ IF (SE%row) THEN
+ CALL disp_sngl(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_sngl(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_sngl
subroutine disp_tm_sngl(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
- ! snglruple precision matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- real(sngl), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
- integer, intent(in), optional :: unit ! Unit to display on
- integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in x
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: zeroas ! Zeros are replaced with this string if it is not empty
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
- !
+ ! snglruple precision matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ REAL(sngl), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in x
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced with this string if it is not empty
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ TYPE(settings) :: SE
+ !
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax)
- call disp_sngl(title, x, SE)
- end subroutine disp_tm_sngl
-
- subroutine disp_sngl(title, x, SE)
- ! snglruple precision item
- character(*), intent(in) :: title
- real(sngl), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- call find_editdesc_sngl(x, SE, wid, nbl) ! determine also SE%w
- call tobox_sngl(title, x, SE, wid, nbl)
- end subroutine disp_sngl
-
- subroutine tobox_sngl(title, x, SE, wid, nbl)
- ! Write snglruple precision matrix to box
- character(*), intent(in) :: title ! title
- real(sngl), intent(in) :: x(:,:) ! item
- type(settings), intent(INOUT ) :: SE ! settings
- integer, intent(INOUT ) :: wid(:) ! widths of columns
- integer, intent(INOUT ) :: nbl(:) ! number of blanks to trim from left
- character(SE%w) :: s(size(x,1))
- integer :: lin1, j, wleft, m, n, widp(size(wid))
- character, pointer :: boxp(:,:)
- real(sngl) :: xj(size(x,1)), h
- m = size(x,1)
- n = size(x,2)
- h = huge(x)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- xj = x(:, j)
- if (m > 0) write(s, SE%ed) xj
+ CALL disp_sngl(title, x, SE)
+END SUBROUTINE disp_tm_sngl
+
+SUBROUTINE disp_sngl(title, x, SE)
+ ! snglruple precision item
+ CHARACTER(*), INTENT(in) :: title
+ REAL(sngl), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ CALL find_editdesc_sngl(x, SE, wid, nbl) ! determine also SE%w
+ CALL tobox_sngl(title, x, SE, wid, nbl)
+END SUBROUTINE disp_sngl
+
+SUBROUTINE tobox_sngl(title, x, SE, wid, nbl)
+ ! Write snglruple precision matrix to box
+ CHARACTER(*), INTENT(in) :: title ! title
+ REAL(sngl), INTENT(in) :: x(:, :) ! item
+ TYPE(settings), INTENT(INOUT) :: SE ! settings
+ INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns
+ INTEGER, INTENT(INOUT) :: nbl(:) ! number of blanks to trim from left
+ CHARACTER(SE%w) :: s(SIZE(x, 1))
+ INTEGER :: lin1, j, wleft, m, n, widp(SIZE(wid))
+ CHARACTER, POINTER :: boxp(:, :)
+ REAL(sngl) :: xj(SIZE(x, 1)), h
+ m = SIZE(x, 1)
+ n = SIZE(x, 2)
+ h = HUGE(x)
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ xj = x(:, j)
+ IF (m > 0) WRITE (s, SE%ed) xj
call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf
- if (.not. any(xfinite)) then
- w = 4
- else
- xmax = maxval(x, mask=xfinite)
- xmin = minval(x, mask=xfinite)
- f1 = '(SS,ES9.0E4)'
- write(s,f1) xmax, xmin
- read(s(:)(5:9),'(I5)') expmax, expmin
- w = max(0, expmax, expmin) + d + 4
- end if
- if (.not. all(xfinite)) w = max(w, 4)
- end function maxw_sngl
-
- subroutine find_editdesc_sngl(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid.
- ! The if-block (*) is for safety: make f wider in case xm is written ok with the
- ! ES format in fmt but overflows with F format (the feature has been tested through
- ! manual changes to the program).
- real(sngl), intent(in) :: x(:,:) ! Item to be written
- type(settings), intent(INOUT ) :: SE ! Settings
- integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns
- integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns
- integer :: expmax, expmin, ww, dd, dmx
- real(sngl) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h
- character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4
- character(99) s
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_sngl
+
+PURE FUNCTION maxw_sngl(x, d) RESULT(w)
+ ! Find max field width needed (F0.d editing is specified)
+ REAL(sngl), INTENT(in) :: x(:)
+ INTEGER, INTENT(in) :: d
+ INTEGER expmax, expmin, w
+ LOGICAL xfinite(SIZE(x))
+ REAL(sngl) xmax, xmin, h
+ CHARACTER(12) :: f1, s(2)
+ xmin = 0; xmax = 0; h = HUGE(h)
+ xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf
+ IF (.NOT. ANY(xfinite)) THEN
+ w = 4
+ ELSE
+ xmax = MAXVAL(x, mask=xfinite)
+ xmin = MINVAL(x, mask=xfinite)
+ f1 = '(SS,ES9.0E4)'
+ WRITE (s, f1) xmax, xmin
+ READ (s(:) (5:9), '(I5)') expmax, expmin
+ w = MAX(0, expmax, expmin) + d + 4
+ END IF
+ IF (.NOT. ALL(xfinite)) w = MAX(w, 4)
+END FUNCTION maxw_sngl
+
+SUBROUTINE find_editdesc_sngl(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid.
+ ! The if-block (*) is for safety: make f wider in case xm is written ok with the
+ ! ES format in fmt but overflows with F format (the feature has been tested through
+ ! manual changes to the program).
+ REAL(sngl), INTENT(in) :: x(:, :) ! Item to be written
+ TYPE(settings), INTENT(INOUT) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)) ! Widths of individual columns
+ INTEGER, INTENT(out) :: nbl(SIZE(x, 2)) ! Blanks to trim from left of individual columns
+ INTEGER :: expmax, expmin, ww, dd, dmx
+ REAL(sngl) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm, h
+ CHARACTER(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4
+ CHARACTER(99) s
logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2))
- !
- dmx = SE%dmx
- h = huge(h)
- xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf
- if (SE%w == 0) then ! Edit descriptor 'F0.d' specified
- ww = maxw_sngl(reshape(x, (/size(x)/)), SE%d)
- if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas)
- call replace_w(SE%ed, ww)
- SE%w = ww
- elseif (SE%w < 0) then ! No edit descriptor specified
- if (size(x) == 0) then
- SE%w = 0
- wid = 0
- nbl = 0
- return
- endif
- if (any(xfinite)) then
- xp = maxval(x, mask=xfinite)
- xm = minval(x, mask=xfinite)
- write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
- write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax
- write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin
- call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0)
- if (.not. all(xfinite)) ww = max(ww, 4)
- if (SE%lzas > 0 .and. any(x == 0._sngl)) ww = max(ww, SE%lzas)
- if (SE%ed(5:5)=='F') then ! (*)
- write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1
- write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1
- write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd
- endif
- else
- ww = 4
- SE%ed = '(F4.0)'
- endif
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1, mask=xfinite) ! max in each column
- xminv = minval(x, 1, mask=xfinite) ! min
- xzero = any(x == 0._sngl, 1) ! true where column has some zeros
- xallz = all(x == 0._sngl, 1) ! true where column has only zeros
- xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan)
- xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan)
- call getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
- else
- wid = SE%w
+ !
+ dmx = SE%dmx
+ h = HUGE(h)
+ xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf
+ IF (SE%w == 0) THEN ! Edit descriptor 'F0.d' specified
+ ww = maxw_sngl(RESHAPE(x, (/SIZE(x)/)), SE%d)
+ IF (SE%lzas > 0 .AND. ANY(x == 0._SNGL)) ww = MAX(ww, SE%lzas)
+ CALL replace_w(SE%ed, ww)
+ SE%w = ww
+ ELSEIF (SE%w < 0) THEN ! No edit descriptor specified
+ IF (SIZE(x) == 0) THEN
+ SE%w = 0
+ wid = 0
nbl = 0
- endif
- end subroutine find_editdesc_sngl
-
- subroutine getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
- ! determine length of the strings that result when writing with edit descriptor SE%ed a
- ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
- real(sngl), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column
- logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros
- logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
- type(settings), intent(in) :: SE ! settings
- integer, intent(out) :: wid(:) ! widths of columns
- integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmin, SE%ed) xminv
- write(stmax, SE%ed) xmaxv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- if (SE%gedit) then
- wid = w
- else
- wid = len_trim(adjustl(stmin))
- wid = max(wid, len_trim(adjustl(stmax)))
- endif
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- endif
- wid = merge(4, wid, xalln)
- wid = max(wid, merge(4, 0, xnonn))
- nbl = w - wid
- end subroutine getwid_sngl
-
- ! ******** TOSTRING snglRUPLE PRECISION PROCEDURES ***********
- function tostring_s_sngl(x) result(st)
- ! Scalar to string
- real(sngl), intent(in) :: x
- character(len_f_sngl((/x/), tosset0%rfmt)) :: st
- st = tostring_f_sngl((/x/), tosset0%rfmt)
- end function tostring_s_sngl
-
- function tostring_sf_sngl(x, fmt) result(st)
- ! Scalar with specified format to string
- real(sngl), intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_sngl((/x/), fmt)) :: st
- st = tostring_f_sngl((/x/), fmt)
- end function tostring_sf_sngl
-
- function tostring_sngl(x) result(st)
- ! Vector to string
- real(sngl), intent(in) :: x(:)
- character(len_f_sngl(x, tosset0%rfmt)) :: st
- st = tostring_f_sngl(x, tosset0%rfmt)
- end function tostring_sngl
-
- function tostring_f_sngl(x, fmt) result(st)
- ! Vector with specified format to string
- real(sngl) , intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_sngl(x, fmt)) :: st
- character(widthmax_sngl(x, fmt)) :: sa(size(x))
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- integer :: w, d, ww
- logical :: gedit
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then
- st = errormsg
- return
- elseif (w == 0) then
- ww = maxw_sngl(x, d)
- call replace_w(fmt1, ww)
- endif
- write(sa, fmt1) x
- call trim_real(sa, gedit, w)
- call tostring_get(sa, st)
- end function tostring_f_sngl
-
- pure function len_f_sngl(x, fmt) result(wtot)
- ! Total length of returned string, vector s
- real(sngl), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_sngl(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d, ww
- logical :: gedit
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- if (w == 0) then
- ww = maxw_sngl(x, d)
- call replace_w(fmt1, ww)
- endif
- write(sa, fmt1) x
- call trim_real(sa, gedit, w)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_sngl
-
- pure function widthmax_sngl(x, fmt) result(w)
- ! Maximum width of an element of x
- real(sngl), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(nnblk(fmt)+5) :: fmt1
- integer w, d
- logical gedit
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then ! illegal format, use 1
- w = 1
- elseif (w == 0) then
- w = maxw_sngl(x, d)
- endif
- end function widthmax_sngl
-
- ! *************************************** END OF snglRUPLE PRECISION PROCEDURES ***************************************
-
- ! *************************************** snglRUPLE PRECISION COMPLEX PROCEDURES **************************************
- subroutine disp_s_cplx(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
- ! snglruple precision complex scalar without title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim
- complex(sngl), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ RETURN
+ END IF
+ IF (ANY(xfinite)) THEN
+ xp = MAXVAL(x, mask=xfinite)
+ xm = MINVAL(x, mask=xfinite)
+ WRITE (f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
+ WRITE (s, f1) xp; READ (s(dmx + 4:dmx + 8), '(I5)') expmax
+ WRITE (s, f1) xm; READ (s(dmx + 4:dmx + 8), '(I5)') expmin
+ CALL find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0)
+ IF (.NOT. ALL(xfinite)) ww = MAX(ww, 4)
+ IF (SE%lzas > 0 .AND. ANY(x == 0._SNGL)) ww = MAX(ww, SE%lzas)
+ IF (SE%ed(5:5) == 'F') THEN ! (*)
+ WRITE (s, SE%ed) xp; IF (s(1:1) == '*') ww = ww + 1
+ WRITE (s, SE%ed) xm; IF (s(1:1) == '*') ww = ww + 1
+ WRITE (SE%ed(6:10), '(SS,I2,".",I2)') ww, dd
+ END IF
+ ELSE
+ ww = 4
+ SE%ed = '(F4.0)'
+ END IF
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1, mask=xfinite) ! max in each column
+ xminv = MINVAL(x, 1, mask=xfinite) ! min
+ xzero = ANY(x == 0._SNGL, 1) ! true where column has some zeros
+ xallz = ALL(x == 0._SNGL, 1) ! true where column has only zeros
+ xnonn = ANY(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan)
+ xalln = ALL(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan)
+ CALL getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_sngl
+
+SUBROUTINE getwid_sngl(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
+ ! determine length of the strings that result when writing with edit descriptor SE%ed a
+ ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
+ REAL(sngl), INTENT(in) :: xmaxv(:), xminv(:) ! max and min values in each column
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros
+ LOGICAL, INTENT(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
+ TYPE(settings), INTENT(in) :: SE ! settings
+ INTEGER, INTENT(out) :: wid(:) ! widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! number of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmin, SE%ed) xminv
+ WRITE (stmax, SE%ed) xmaxv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ IF (SE%gedit) THEN
+ wid = w
+ ELSE
+ wid = LEN_TRIM(ADJUSTL(stmin))
+ wid = MAX(wid, LEN_TRIM(ADJUSTL(stmax)))
+ END IF
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ END IF
+ wid = MERGE(4, wid, xalln)
+ wid = MAX(wid, MERGE(4, 0, xnonn))
+ nbl = w - wid
+END SUBROUTINE getwid_sngl
+
+! ******** TOSTRING snglRUPLE PRECISION PROCEDURES ***********
+FUNCTION tostring_s_sngl(x) RESULT(st)
+ ! Scalar to string
+ REAL(sngl), INTENT(in) :: x
+ CHARACTER(len_f_sngl((/x/), tosset0%rfmt)) :: st
+ st = tostring_f_sngl((/x/), tosset0%rfmt)
+END FUNCTION tostring_s_sngl
+
+FUNCTION tostring_sf_sngl(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ REAL(sngl), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_sngl((/x/), fmt)) :: st
+ st = tostring_f_sngl((/x/), fmt)
+END FUNCTION tostring_sf_sngl
+
+FUNCTION tostring_sngl(x) RESULT(st)
+ ! Vector to string
+ REAL(sngl), INTENT(in) :: x(:)
+ CHARACTER(len_f_sngl(x, tosset0%rfmt)) :: st
+ st = tostring_f_sngl(x, tosset0%rfmt)
+END FUNCTION tostring_sngl
+
+FUNCTION tostring_f_sngl(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ REAL(sngl), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_sngl(x, fmt)) :: st
+ CHARACTER(widthmax_sngl(x, fmt)) :: sa(SIZE(x))
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ INTEGER :: w, d, ww
+ LOGICAL :: gedit
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN
+ st = errormsg
+ RETURN
+ ELSEIF (w == 0) THEN
+ ww = maxw_sngl(x, d)
+ CALL replace_w(fmt1, ww)
+ END IF
+ WRITE (sa, fmt1) x
+ CALL trim_real(sa, gedit, w)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_sngl
+
+PURE FUNCTION len_f_sngl(x, fmt) RESULT(wtot)
+ ! Total length of returned string, vector s
+ REAL(sngl), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_sngl(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d, ww
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ IF (w == 0) THEN
+ ww = maxw_sngl(x, d)
+ CALL replace_w(fmt1, ww)
+ END IF
+ WRITE (sa, fmt1) x
+ CALL trim_real(sa, gedit, w)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_sngl
+
+PURE FUNCTION widthmax_sngl(x, fmt) RESULT(w)
+ ! Maximum width of an element of x
+ REAL(sngl), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ INTEGER w, d
+ LOGICAL gedit
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN ! illegal format, use 1
+ w = 1
+ ELSEIF (w == 0) THEN
+ w = maxw_sngl(x, d)
+ END IF
+END FUNCTION widthmax_sngl
+
+! *************************************** END OF snglRUPLE PRECISION PROCEDURES ***************************************
+
+! *************************************** snglRUPLE PRECISION COMPLEX PROCEDURES **************************************
+SUBROUTINE disp_s_cplx(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
+ ! snglruple precision complex scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, trim
+ COMPLEX(sngl), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_ts_cplx('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit)
- end subroutine disp_s_cplx
+END SUBROUTINE disp_s_cplx
subroutine disp_v_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- ! snglruple precision complex vector without title
+ ! snglruple precision complex vector without title
character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
- complex(sngl), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
+ COMPLEX(sngl), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
call disp_tv_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- end subroutine disp_v_cplx
+END SUBROUTINE disp_v_cplx
subroutine disp_m_cplx(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- ! snglruple precision complex matrix without title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
- complex(sngl), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, digmax, lbound(:)
+ ! snglruple precision complex matrix without title
+CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim
+ COMPLEX(sngl), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:)
call disp_tm_cplx('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- end subroutine disp_m_cplx
+END SUBROUTINE disp_m_cplx
subroutine disp_ts_cplx(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit)
- ! snglruple precision complex scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
- complex(sngl), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ ! snglruple precision complex scalar with title
+ CHARACTER(*), INTENT(in) :: title
+CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim
+ COMPLEX(sngl), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_tm_cplx(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, &
- trim=trim, unit=unit)
- end subroutine disp_ts_cplx
+ trim=trim, unit=unit)
+END SUBROUTINE disp_ts_cplx
subroutine disp_tv_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- ! snglruple precision complex vector with title
- character(*), intent(in) :: title
+ ! snglruple precision complex vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
- complex(sngl), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
- type(settings) SE, SEim
+ COMPLEX(sngl), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
+ TYPE(settings) SE, SEim
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax)
- if (present(fmt_imag)) then
- if (.not.present(fmt)) then
- call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return;
- endif
- call get_SE(SEim, title, shape(x), fmt_imag)
- else
- SEim = SE
- end if
- if (SE%row) then
- call disp_cplx(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x))
- else
- call disp_cplx(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1)
- end if
- end subroutine disp_tv_cplx
+ IF (PRESENT(fmt_imag)) THEN
+ IF (.NOT. PRESENT(fmt)) THEN
+ CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN;
+ END IF
+ CALL get_SE(SEim, title, SHAPE(x), fmt_imag)
+ ELSE
+ SEim = SE
+ END IF
+ IF (SE%row) THEN
+ CALL disp_cplx(title, RESHAPE(x, (/1, SIZE(x)/)), SE, SEim, n=SIZE(x))
+ ELSE
+ CALL disp_cplx(title, RESHAPE(x, (/SIZE(x), 1/)), SE, SEim, n=1)
+ END IF
+END SUBROUTINE disp_tv_cplx
subroutine disp_tm_cplx(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- ! snglruple precision complex matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- complex(sngl), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag &
- ! ! is present)
- character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element
- integer, intent(in), optional :: unit ! Unit to display on
- integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) &
- ! ! and aimag(x)
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- !
- type(settings) :: SE, SEim
+ ! snglruple precision complex matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ COMPLEX(sngl), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Edit descriptor for each element (real element when fmt_imag &
+ ! ! is present)
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt_imag ! Edit descriptor for each imaginary element
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in real(x) &
+ ! ! and aimag(x)
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ !
+ TYPE(settings) :: SE, SEim
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax)
- if (present(fmt_imag)) then
- if (.not.present(fmt)) then
- call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return
- endif
- call get_SE(SEim, title, shape(x), fmt_imag)
- else
- SEim = SE
- end if
- call disp_cplx(title, x, SE, SEim, n = size(x,2))
- end subroutine disp_tm_cplx
-
- subroutine disp_cplx(title, x, SE, SEim, n)
- ! snglruple precision item
- character(*), intent(in) :: title
- complex(sngl), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE, SEim
- integer, intent(in) :: n
- integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n)
- call find_editdesc_sngl(real(x), SE, widre, nblre) ! determine also SE%w
- call find_editdesc_sngl(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w
+ IF (PRESENT(fmt_imag)) THEN
+ IF (.NOT. PRESENT(fmt)) THEN
+ CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN
+ END IF
+ CALL get_SE(SEim, title, SHAPE(x), fmt_imag)
+ ELSE
+ SEim = SE
+ END IF
+ CALL disp_cplx(title, x, SE, SEim, n=SIZE(x, 2))
+END SUBROUTINE disp_tm_cplx
+
+SUBROUTINE disp_cplx(title, x, SE, SEim, n)
+ ! snglruple precision item
+ CHARACTER(*), INTENT(in) :: title
+ COMPLEX(sngl), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE, SEim
+ INTEGER, INTENT(in) :: n
+ INTEGER, DIMENSION(n) :: widre(n), widim(n), nblre(n), nblim(n)
+ CALL find_editdesc_sngl(REAL(x), SE, widre, nblre) ! determine also SE%w
+ CALL find_editdesc_sngl(ABS(AIMAG(x)), SEim, widim, nblim) ! determine also SEim%w
call tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2))
- end subroutine disp_cplx
-
- subroutine tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
- ! Write snglruple precision complex matrix to box
- character(*), intent(in) :: title
- complex(sngl), intent(in) :: x(:,:)
- integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:)
- type(settings), intent(INOUT ) :: SE, SEim
- character(SE%w) :: s(m)
- character(SEim%w) :: sim(m)
- character(3) :: sgn(m)
- integer :: lin1, i, j, wleft, wid(n), widp(n)
- character, pointer :: boxp(:,:)
- SE%zas = ''
- SEim%zas = ''
- wid = widre + widim + 4
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m)
+END SUBROUTINE disp_cplx
+
+SUBROUTINE tobox_cplx(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
+ ! Write snglruple precision complex matrix to box
+ CHARACTER(*), INTENT(in) :: title
+ COMPLEX(sngl), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:)
+ TYPE(settings), INTENT(INOUT) :: SE, SEim
+ CHARACTER(SE%w) :: s(m)
+ CHARACTER(SEim%w) :: sim(m)
+ CHARACTER(3) :: sgn(m)
+ INTEGER :: lin1, i, j, wleft, wid(n), widp(n)
+ CHARACTER, POINTER :: boxp(:, :)
+ SE%zas = ''
+ SEim%zas = ''
+ wid = widre + widim + 4
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ IF (m > 0) WRITE (s, SE%ed) (REAL(x(i, j)), i=1, m)
call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft)
- do i=1,m
- if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif
- enddo
- call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft)
- if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m)
- call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft)
- call copyseptobox('i', m, lin1, boxp, wleft)
- if (j 0) WRITE (sim, SEim%ed) (ABS(AIMAG(x(i, j))), i=1, m)
+ CALL copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft)
+ CALL copyseptobox('i', m, lin1, boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_cplx
+
+! ******* TOSTRING snglRUPLE PRECISION COMPLEX PROCEDURES ********
+
+FUNCTION tostring_s_cplx(x) RESULT(st)
+ COMPLEX(sngl), INTENT(in) :: x
+ CHARACTER(len_s_cplx(x, tosset0%rfmt)) :: st
+ st = tostring_f_cplx((/x/), tosset0%rfmt)
+END FUNCTION tostring_s_cplx
+
+FUNCTION tostring_sf_cplx(x, fmt) RESULT(st)
+ COMPLEX(sngl), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_s_cplx(x, fmt)) :: st
+ st = tostring_f_cplx((/x/), fmt)
+END FUNCTION tostring_sf_cplx
+
+FUNCTION tostring_cplx(x) RESULT(st)
+ COMPLEX(sngl), INTENT(in) :: x(:)
+ CHARACTER(len_f_cplx(x, tosset0%rfmt)) :: st
+ st = tostring_f_cplx(x, tosset0%rfmt)
+END FUNCTION tostring_cplx
+
+FUNCTION tostring_f_cplx(x, fmt) RESULT(st)
+ COMPLEX(sngl), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_cplx(x, fmt)) :: st
+ CHARACTER(widthmax_sngl(REAL(x), fmt)) :: sar(SIZE(x))
+ CHARACTER(widthmax_sngl(ABS(x - REAL(x)), fmt)) :: sai(SIZE(x)) ! x-real(x) instead of aimag(x) to enable the fnction
+ CHARACTER(1) :: sgn(SIZE(x)) ! to pass -stand:f95 switch of the ifort compiler.
+ INTEGER :: w, d, wr, wi, i
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ REAL(sngl) :: xre(SIZE(x)), xim(SIZE(x)), h
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ xre = REAL(x)
+ xim = AIMAG(x)
+ h = HUGE(h)
+ IF (w < 0) THEN
+ st = errormsg
+ RETURN
+ ELSEIF (w == 0) THEN
+ wr = maxw_sngl(xre, d)
+ wi = maxw_sngl(xim, d)
+ CALL replace_w(fmt1, MAX(wr, wi))
+ END IF
+ WRITE (sar, fmt1) REAL(x)
+ WRITE (sai, fmt1) ABS(AIMAG(x))
+ CALL trim_real(sar, gedit, w)
+ CALL trim_real(sai, gedit, w)
+ DO i = 1, SIZE(x); IF (AIMAG(x(i)) < 0) THEN; sgn(i) = '-'; ELSE; sgn(i) = '+'; END IF; END DO
+ CALL tostring_get_complex(sar, sgn, sai, st)
+END FUNCTION tostring_f_cplx
+
+PURE FUNCTION len_s_cplx(x, fmt) RESULT(wtot)
+ COMPLEX(sngl), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ wtot = len_f_sngl((/REAL(x)/), fmt) + len_f_sngl((/ABS(AIMAG(x))/), fmt) + 4
+END FUNCTION len_s_cplx
+
+PURE FUNCTION len_f_cplx(x, fmt) RESULT(wtot)
+ COMPLEX(sngl), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
wtot = len_f_sngl(real(x), fmt) + len_f_sngl(abs(aimag(x)), fmt) + size(x)*4 - (size(x) - 1)*(tosset0%seplen)
- ! subtract seplen because it has been added twice in len_f_sngl
- end function len_f_cplx
+ ! subtract seplen because it has been added twice in len_f_sngl
+END FUNCTION len_f_cplx
END MODULE DISP_R4MOD
diff --git a/src/modules/Display/src/disp/disp_r8mod.F90 b/src/modules/Display/src/disp/disp_r8mod.F90
index 5a32ff45d..7cdfae842 100755
--- a/src/modules/Display/src/disp/disp_r8mod.F90
+++ b/src/modules/Display/src/disp/disp_r8mod.F90
@@ -11,7 +11,7 @@
MODULE DISP_R8MOD
USE DISPMODULE_UTIL
-USE GlobalData, ONLY: Real64
+USE GlobalData, ONLY: REAL64
PUBLIC DISP
PUBLIC TOSTRING
PRIVATE
@@ -34,7 +34,7 @@ MODULE DISP_R8MOD
MODULE PROCEDURE tostring_cpld, tostring_f_cpld, tostring_s_cpld, tostring_sf_cpld
END INTERFACE TOSTRING
-INTEGER, PARAMETER :: dble = Real64
+INTEGER, PARAMETER :: dble = REAL64
CONTAINS
@@ -42,625 +42,623 @@ MODULE DISP_R8MOD
!
!----------------------------------------------------------------------------
- subroutine disp_s_dble(x, fmt, advance, digmax, sep, trim, unit, zeroas)
- ! dbleruple precision scalar without title
- character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
- real(dble), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+SUBROUTINE disp_s_dble(x, fmt, advance, digmax, sep, trim, unit, zeroas)
+ ! dbleruple precision scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, trim, zeroas
+ REAL(dble), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_ts_dble('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas)
- end subroutine disp_s_dble
+END SUBROUTINE disp_s_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_v_dble(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- ! dbleruple precision vector without title
+ ! dbleruple precision vector without title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- real(dble), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
+ REAL(dble), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
call disp_tv_dble('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- end subroutine disp_v_dble
+END SUBROUTINE disp_v_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_m_dble(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas)
- ! dbleruple precision matrix without title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- real(dble), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, digmax, lbound(:)
+ ! dbleruple precision matrix without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ REAL(dble), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:)
call disp_tm_dble('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
- end subroutine disp_m_dble
+END SUBROUTINE disp_m_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_ts_dble(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas)
- ! dbleruple precision scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
- real(dble), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+ ! dbleruple precision scalar with title
+ CHARACTER(*), INTENT(in) :: title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, advance, sep, style, trim, zeroas
+ REAL(dble), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_tm_dble(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, &
- & unit=unit, zeroas=zeroas)
- end subroutine disp_ts_dble
+ & unit=unit, zeroas=zeroas)
+END SUBROUTINE disp_ts_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_tv_dble(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
- ! dbleruple precision vector with title
- character(*), intent(in) :: title
+ ! dbleruple precision vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
- real(dble), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
- type(settings) :: SE
+ REAL(dble), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
+ TYPE(settings) :: SE
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax)
- if (SE%row) then
- call disp_dble(title, reshape(x, (/1, size(x)/)), SE)
- else
- call disp_dble(title, reshape(x, (/size(x), 1/)), SE)
- end if
- end subroutine disp_tv_dble
+ IF (SE%row) THEN
+ CALL disp_dble(title, RESHAPE(x, (/1, SIZE(x)/)), SE)
+ ELSE
+ CALL disp_dble(title, RESHAPE(x, (/SIZE(x), 1/)), SE)
+ END IF
+END SUBROUTINE disp_tv_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_tm_dble(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
- ! dbleruple precision matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- real(dble), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
- integer, intent(in), optional :: unit ! Unit to display on
- integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in x
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: zeroas ! Zeros are replaced with this string if it is not empty
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- type(settings) :: SE
- !
+ ! dbleruple precision matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ REAL(dble), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in x
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: zeroas ! Zeros are replaced with this string if it is not empty
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ TYPE(settings) :: SE
+ !
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax)
- call disp_dble(title, x, SE)
- end subroutine disp_tm_dble
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- subroutine disp_dble(title, x, SE)
- ! dbleruple precision item
- character(*), intent(in) :: title
- real(dble), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE
- integer wid(size(x,2)), nbl(size(x,2))
- call find_editdesc_dble(x, SE, wid, nbl) ! determine also SE%w
- call tobox_dble(title, x, SE, wid, nbl)
- end subroutine disp_dble
-
- subroutine tobox_dble(title, x, SE, wid, nbl)
- ! Write dbleruple precision matrix to box
- character(*), intent(in) :: title ! title
- real(dble), intent(in) :: x(:,:) ! item
- type(settings), intent(INOUT ) :: SE ! settings
- integer, intent(INOUT ) :: wid(:) ! widths of columns
- integer, intent(INOUT ) :: nbl(:) ! number of blanks to trim from left
- character(SE%w) :: s(size(x,1))
- integer :: lin1, j, wleft, m, n, widp(size(wid))
- character, pointer :: boxp(:,:)
- real(dble) :: xj(size(x,1)), h
- m = size(x,1)
- n = size(x,2)
- h = huge(x)
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- xj = x(:, j)
- if (m > 0) write(s, SE%ed) xj
+ CALL disp_dble(title, x, SE)
+END SUBROUTINE disp_tm_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE disp_dble(title, x, SE)
+ ! dbleruple precision item
+ CHARACTER(*), INTENT(in) :: title
+ REAL(dble), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE
+ INTEGER wid(SIZE(x, 2)), nbl(SIZE(x, 2))
+ CALL find_editdesc_dble(x, SE, wid, nbl) ! determine also SE%w
+ CALL tobox_dble(title, x, SE, wid, nbl)
+END SUBROUTINE disp_dble
+
+SUBROUTINE tobox_dble(title, x, SE, wid, nbl)
+ ! Write dbleruple precision matrix to box
+ CHARACTER(*), INTENT(in) :: title ! title
+ REAL(dble), INTENT(in) :: x(:, :) ! item
+ TYPE(settings), INTENT(INOUT) :: SE ! settings
+ INTEGER, INTENT(INOUT) :: wid(:) ! widths of columns
+ INTEGER, INTENT(INOUT) :: nbl(:) ! number of blanks to trim from left
+ CHARACTER(SE%w) :: s(SIZE(x, 1))
+ INTEGER :: lin1, j, wleft, m, n, widp(SIZE(wid))
+ CHARACTER, POINTER :: boxp(:, :)
+ REAL(dble) :: xj(SIZE(x, 1)), h
+ m = SIZE(x, 1)
+ n = SIZE(x, 2)
+ h = HUGE(x)
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ xj = x(:, j)
+ IF (m > 0) WRITE (s, SE%ed) xj
call replace_zeronaninf(s, SE%zas(1:SE%lzas), xj == 0, xj /= xj, xj < -h, xj > h)
- call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
- if (j= -h .and. x <= h ! neither NaN, Inf nor -Inf
- if (.not. any(xfinite)) then
- w = 4
- else
- xmax = maxval(x, mask=xfinite)
- xmin = minval(x, mask=xfinite)
- f1 = '(SS,ES9.0E4)'
- write(s,f1) xmax, xmin
- read(s(:)(5:9),'(I5)') expmax, expmin
- w = max(0, expmax, expmin) + d + 4
- end if
- if (.not. all(xfinite)) w = max(w, 4)
- end function maxw_dble
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- subroutine find_editdesc_dble(x, SE, wid, nbl)
- ! Determine SE%ed, SE%w (unless specified) and wid.
- ! The if-block (*) is for safety: make f wider in case xm is written ok with the
- ! ES format in fmt but overflows with F format (the feature has been tested through
- ! manual changes to the program).
- real(dble), intent(in) :: x(:,:) ! Item to be written
- type(settings), intent(INOUT ) :: SE ! Settings
- integer, intent(out) :: wid(size(x,2)) ! Widths of individual columns
- integer, intent(out) :: nbl(size(x,2)) ! Blanks to trim from left of individual columns
- integer :: expmax, expmin, ww, dd, dmx
- real(dble) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h
- character(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4
- character(99) s
+ CALL copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION maxw_dble(x, d) RESULT(w)
+ ! Find max field width needed (F0.d editing is specified)
+ REAL(dble), INTENT(in) :: x(:)
+ INTEGER, INTENT(in) :: d
+ INTEGER expmax, expmin, w
+ LOGICAL xfinite(SIZE(x))
+ REAL(dble) xmax, xmin, h
+ CHARACTER(12) :: f1, s(2)
+ xmin = 0; xmax = 0; h = HUGE(h)
+ xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf
+ IF (.NOT. ANY(xfinite)) THEN
+ w = 4
+ ELSE
+ xmax = MAXVAL(x, mask=xfinite)
+ xmin = MINVAL(x, mask=xfinite)
+ f1 = '(SS,ES9.0E4)'
+ WRITE (s, f1) xmax, xmin
+ READ (s(:) (5:9), '(I5)') expmax, expmin
+ w = MAX(0, expmax, expmin) + d + 4
+ END IF
+ IF (.NOT. ALL(xfinite)) w = MAX(w, 4)
+END FUNCTION maxw_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE find_editdesc_dble(x, SE, wid, nbl)
+ ! Determine SE%ed, SE%w (unless specified) and wid.
+ ! The if-block (*) is for safety: make f wider in case xm is written ok with the
+ ! ES format in fmt but overflows with F format (the feature has been tested through
+ ! manual changes to the program).
+ REAL(dble), INTENT(in) :: x(:, :) ! Item to be written
+ TYPE(settings), INTENT(INOUT) :: SE ! Settings
+ INTEGER, INTENT(out) :: wid(SIZE(x, 2)) ! Widths of individual columns
+ INTEGER, INTENT(out) :: nbl(SIZE(x, 2)) ! Blanks to trim from left of individual columns
+ INTEGER :: expmax, expmin, ww, dd, dmx
+ REAL(dble) xmaxv(SIZE(x, 2)), xminv(SIZE(x, 2)), xp, xm, h
+ CHARACTER(14) :: f1 = '(SS,ESxx.xxE4)' ! could be ES99.89E4; default is ES14.05E4
+ CHARACTER(99) s
logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2))
- !
- dmx = SE%dmx
- h = huge(h)
- xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf
- if (SE%w == 0) then ! Edit descriptor 'F0.d' specified
- ww = maxw_dble(reshape(x, (/size(x)/)), SE%d)
- if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas)
- call replace_w(SE%ed, ww)
- SE%w = ww
- elseif (SE%w < 0) then ! No edit descriptor specified
- if (size(x) == 0) then
- SE%w = 0
- wid = 0
- nbl = 0
- return
- endif
- if (any(xfinite)) then
- xp = maxval(x, mask=xfinite)
- xm = minval(x, mask=xfinite)
- write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
- write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax
- write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin
- call find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0)
- if (.not. all(xfinite)) ww = max(ww, 4)
- if (SE%lzas > 0 .and. any(x == 0._dble)) ww = max(ww, SE%lzas)
- if (SE%ed(5:5)=='F') then ! (*)
- write(s, SE%ed) xp; if (s(1:1) == '*') ww = ww + 1
- write(s, SE%ed) xm; if (s(1:1) == '*') ww = ww + 1
- write(SE%ed(6:10), '(SS,I2,".",I2)') ww, dd
- endif
- else
- ww = 4
- SE%ed = '(F4.0)'
- endif
- SE%w = ww
- endif
- if (SE%trm) then
- xmaxv = maxval(x, 1, mask=xfinite) ! max in each column
- xminv = minval(x, 1, mask=xfinite) ! min
- xzero = any(x == 0._dble, 1) ! true where column has some zeros
- xallz = all(x == 0._dble, 1) ! true where column has only zeros
- xnonn = any(x > h .or. x < -h .or. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan)
- xalln = all(x > h .or. x < -h .or. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan)
- call getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
- else
- wid = SE%w
+ !
+ dmx = SE%dmx
+ h = HUGE(h)
+ xfinite = x == x .AND. x >= -h .AND. x <= h ! neither NaN, Inf nor -Inf
+ IF (SE%w == 0) THEN ! Edit descriptor 'F0.d' specified
+ ww = maxw_dble(RESHAPE(x, (/SIZE(x)/)), SE%d)
+ IF (SE%lzas > 0 .AND. ANY(x == 0._DBLE)) ww = MAX(ww, SE%lzas)
+ CALL replace_w(SE%ed, ww)
+ SE%w = ww
+ ELSEIF (SE%w < 0) THEN ! No edit descriptor specified
+ IF (SIZE(x) == 0) THEN
+ SE%w = 0
+ wid = 0
nbl = 0
- endif
- end subroutine find_editdesc_dble
+ RETURN
+ END IF
+ IF (ANY(xfinite)) THEN
+ xp = MAXVAL(x, mask=xfinite)
+ xm = MINVAL(x, mask=xfinite)
+ WRITE (f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
+ WRITE (s, f1) xp; READ (s(dmx + 4:dmx + 8), '(I5)') expmax
+ WRITE (s, f1) xm; READ (s(dmx + 4:dmx + 8), '(I5)') expmin
+ CALL find_editdesc_real(expmax, expmin, dmx, SE%ed, ww, dd, xm >= 0)
+ IF (.NOT. ALL(xfinite)) ww = MAX(ww, 4)
+ IF (SE%lzas > 0 .AND. ANY(x == 0._DBLE)) ww = MAX(ww, SE%lzas)
+ IF (SE%ed(5:5) == 'F') THEN ! (*)
+ WRITE (s, SE%ed) xp; IF (s(1:1) == '*') ww = ww + 1
+ WRITE (s, SE%ed) xm; IF (s(1:1) == '*') ww = ww + 1
+ WRITE (SE%ed(6:10), '(SS,I2,".",I2)') ww, dd
+ END IF
+ ELSE
+ ww = 4
+ SE%ed = '(F4.0)'
+ END IF
+ SE%w = ww
+ END IF
+ IF (SE%trm) THEN
+ xmaxv = MAXVAL(x, 1, mask=xfinite) ! max in each column
+ xminv = MINVAL(x, 1, mask=xfinite) ! min
+ xzero = ANY(x == 0._DBLE, 1) ! true where column has some zeros
+ xallz = ALL(x == 0._DBLE, 1) ! true where column has only zeros
+ xnonn = ANY(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has some nonnormals (inf, -inf, nan)
+ xalln = ALL(x > h .OR. x < -h .OR. x /= x, 1) ! true where column has only nonnormals (inf, -inf, nan)
+ CALL getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
+ ELSE
+ wid = SE%w
+ nbl = 0
+ END IF
+END SUBROUTINE find_editdesc_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
+ ! determine length of the strings that result when writing with edit descriptor SE%ed a
+ ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
+ REAL(dble), INTENT(in) :: xmaxv(:), xminv(:) ! max and min values in each column
+ LOGICAL, INTENT(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros
+ LOGICAL, INTENT(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
+ TYPE(settings), INTENT(in) :: SE ! settings
+ INTEGER, INTENT(out) :: wid(:) ! widths of columns
+ INTEGER, INTENT(out) :: nbl(:) ! number of blanks to peel from left (w-wid)
+ CHARACTER(SE%w) :: stmax(SIZE(xmaxv)), stmin(SIZE(xmaxv))
+ INTEGER w
+ w = SE%w
+ WRITE (stmin, SE%ed) xminv
+ WRITE (stmax, SE%ed) xmaxv
+ nbl = MOD(VERIFY(stmin, ' ') + w, w + 1) ! loc. of first nonblank
+ nbl = MIN(nbl, MOD(VERIFY(stmax, ' ') + w, w + 1))
+ IF (SE%gedit) THEN
+ wid = w
+ ELSE
+ wid = LEN_TRIM(ADJUSTL(stmin))
+ wid = MAX(wid, LEN_TRIM(ADJUSTL(stmax)))
+ END IF
+ IF (SE%lzas > 0) THEN
+ wid = MERGE(SE%lzas, wid, xallz)
+ wid = MAX(wid, MERGE(SE%lzas, 0, xzero))
+ END IF
+ wid = MERGE(4, wid, xalln)
+ wid = MAX(wid, MERGE(4, 0, xnonn))
+ nbl = w - wid
+END SUBROUTINE getwid_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+FUNCTION tostring_s_dble(x) RESULT(st)
+ ! Scalar to string
+ REAL(dble), INTENT(in) :: x
+ CHARACTER(len_f_dble((/x/), tosset0%rfmt)) :: st
+ st = tostring_f_dble((/x/), tosset0%rfmt)
+END FUNCTION tostring_s_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+FUNCTION tostring_sf_dble(x, fmt) RESULT(st)
+ ! Scalar with specified format to string
+ REAL(dble), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_dble((/x/), fmt)) :: st
+ st = tostring_f_dble((/x/), fmt)
+END FUNCTION tostring_sf_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+FUNCTION tostring_dble(x) RESULT(st)
+ ! Vector to string
+ REAL(dble), INTENT(in) :: x(:)
+ CHARACTER(len_f_dble(x, tosset0%rfmt)) :: st
+ st = tostring_f_dble(x, tosset0%rfmt)
+END FUNCTION tostring_dble
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+FUNCTION tostring_f_dble(x, fmt) RESULT(st)
+ ! Vector with specified format to string
+ REAL(dble), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_dble(x, fmt)) :: st
+ CHARACTER(widthmax_dble(x, fmt)) :: sa(SIZE(x))
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ INTEGER :: w, d, ww
+ LOGICAL :: gedit
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN
+ st = errormsg
+ RETURN
+ ELSEIF (w == 0) THEN
+ ww = maxw_dble(x, d)
+ CALL replace_w(fmt1, ww)
+ END IF
+ WRITE (sa, fmt1) x
+ CALL trim_real(sa, gedit, w)
+ CALL tostring_get(sa, st)
+END FUNCTION tostring_f_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- subroutine getwid_dble(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE, wid, nbl)
- ! determine length of the strings that result when writing with edit descriptor SE%ed a
- ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
- real(dble), intent(in) :: xmaxv(:), xminv(:) ! max and min values in each column
- logical, intent(in) :: xzero(:), xallz(:) ! true for columns with some/all zeros
- logical, intent(in) :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
- type(settings), intent(in) :: SE ! settings
- integer, intent(out) :: wid(:) ! widths of columns
- integer, intent(out) :: nbl(:) ! number of blanks to peel from left (w-wid)
- character(SE%w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
- integer w
- w = SE%w
- write(stmin, SE%ed) xminv
- write(stmax, SE%ed) xmaxv
- nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
- nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
- if (SE%gedit) then
- wid = w
- else
- wid = len_trim(adjustl(stmin))
- wid = max(wid, len_trim(adjustl(stmax)))
- endif
- if (SE%lzas > 0) then
- wid = merge(SE%lzas, wid, xallz)
- wid = max(wid, merge(SE%lzas, 0, xzero))
- endif
- wid = merge(4, wid, xalln)
- wid = max(wid, merge(4, 0, xnonn))
- nbl = w - wid
- end subroutine getwid_dble
-
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- function tostring_s_dble(x) result(st)
- ! Scalar to string
- real(dble), intent(in) :: x
- character(len_f_dble((/x/), tosset0%rfmt)) :: st
- st = tostring_f_dble((/x/), tosset0%rfmt)
- end function tostring_s_dble
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- function tostring_sf_dble(x, fmt) result(st)
- ! Scalar with specified format to string
- real(dble), intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_f_dble((/x/), fmt)) :: st
- st = tostring_f_dble((/x/), fmt)
- end function tostring_sf_dble
+PURE FUNCTION len_f_dble(x, fmt) RESULT(wtot)
+ ! Total length of returned string, vector s
+ REAL(dble), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(widthmax_dble(x, fmt)) :: sa(SIZE(x))
+ INTEGER :: wtot, w, d, ww
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ IF (w == 0) THEN
+ ww = maxw_dble(x, d)
+ CALL replace_w(fmt1, ww)
+ END IF
+ WRITE (sa, fmt1) x
+ CALL trim_real(sa, gedit, w)
+ wtot = SUM(LEN_TRIM(sa)) + (SIZE(x) - 1) * (tosset0%seplen)
+END FUNCTION len_f_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- function tostring_dble(x) result(st)
- ! Vector to string
- real(dble), intent(in) :: x(:)
- character(len_f_dble(x, tosset0%rfmt)) :: st
- st = tostring_f_dble(x, tosset0%rfmt)
- end function tostring_dble
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- function tostring_f_dble(x, fmt) result(st)
- ! Vector with specified format to string
- real(dble) , intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_dble(x, fmt)) :: st
- character(widthmax_dble(x, fmt)) :: sa(size(x))
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- integer :: w, d, ww
- logical :: gedit
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then
- st = errormsg
- return
- elseif (w == 0) then
- ww = maxw_dble(x, d)
- call replace_w(fmt1, ww)
- endif
- write(sa, fmt1) x
- call trim_real(sa, gedit, w)
- call tostring_get(sa, st)
- end function tostring_f_dble
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- pure function len_f_dble(x, fmt) result(wtot)
- ! Total length of returned string, vector s
- real(dble), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(widthmax_dble(x, fmt)) :: sa(size(x))
- integer :: wtot, w, d, ww
- logical :: gedit
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- if (w == 0) then
- ww = maxw_dble(x, d)
- call replace_w(fmt1, ww)
- endif
- write(sa, fmt1) x
- call trim_real(sa, gedit, w)
- wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset0%seplen)
- end function len_f_dble
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- pure function widthmax_dble(x, fmt) result(w)
- ! Maximum width of an element of x
- real(dble), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(nnblk(fmt)+5) :: fmt1
- integer w, d
- logical gedit
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then ! illegal format, use 1
- w = 1
- elseif (w == 0) then
- w = maxw_dble(x, d)
- endif
- end function widthmax_dble
-
+PURE FUNCTION widthmax_dble(x, fmt) RESULT(w)
+ ! Maximum width of an element of x
+ REAL(dble), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(nnblk(fmt) + 5) :: fmt1
+ INTEGER w, d
+ LOGICAL gedit
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN ! illegal format, use 1
+ w = 1
+ ELSEIF (w == 0) THEN
+ w = maxw_dble(x, d)
+ END IF
+END FUNCTION widthmax_dble
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- subroutine disp_s_cpld(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
- ! dbleruple precision complex scalar without title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim
- complex(dble), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
+SUBROUTINE disp_s_cpld(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
+ ! dbleruple precision complex scalar without title
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, trim
+ COMPLEX(dble), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
call disp_ts_cpld('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit)
- end subroutine disp_s_cpld
+END SUBROUTINE disp_s_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_v_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- ! dbleruple precision complex vector without title
+ ! dbleruple precision complex vector without title
character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
- complex(dble), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
+ COMPLEX(dble), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
call disp_tv_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- end subroutine disp_v_cpld
+END SUBROUTINE disp_v_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_m_cpld(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- ! dbleruple precision complex matrix without title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
- complex(dble), intent(in) :: x(:,:)
- integer, intent(in), optional :: unit, digmax, lbound(:)
+ ! dbleruple precision complex matrix without title
+CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim
+ COMPLEX(dble), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax, LBOUND(:)
call disp_tm_cpld('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- end subroutine disp_m_cpld
+END SUBROUTINE disp_m_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_ts_cpld(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit)
- ! dbleruple precision complex scalar with title
- character(*), intent(in) :: title
- character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
- complex(dble), intent(in) :: x
- integer, intent(in), optional :: unit, digmax
- call disp_tm_cpld(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, &
- & advance, digmax, sep=sep, style=style, trim=trim, unit=unit)
- end subroutine disp_ts_cpld
+ ! dbleruple precision complex scalar with title
+ CHARACTER(*), INTENT(in) :: title
+CHARACTER(*), INTENT(in), OPTIONAL :: fmt, fmt_imag, advance, sep, style, trim
+ COMPLEX(dble), INTENT(in) :: x
+ INTEGER, INTENT(in), OPTIONAL :: unit, digmax
+ CALL disp_tm_cpld(title, RESHAPE((/x/), (/1, 1/)), fmt, fmt_imag, &
+ & advance, digmax, sep=sep, style=style, trim=trim, unit=unit)
+END SUBROUTINE disp_ts_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_tv_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
- ! dbleruple precision complex vector with title
- character(*), intent(in) :: title
+ ! dbleruple precision complex vector with title
+ CHARACTER(*), INTENT(in) :: title
character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
- complex(dble), intent(in) :: x(:)
- integer, intent(in), optional :: unit, lbound(:), digmax
- type(settings) SE, SEim
+ COMPLEX(dble), INTENT(in) :: x(:)
+ INTEGER, INTENT(in), OPTIONAL :: unit, LBOUND(:), digmax
+ TYPE(settings) SE, SEim
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax)
- if (present(fmt_imag)) then
- if (.not.present(fmt)) then
- call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return;
- endif
- call get_SE(SEim, title, shape(x), fmt_imag)
- else
- SEim = SE
- end if
- if (SE%row) then
- call disp_cpld(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x))
- else
- call disp_cpld(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1)
- end if
- end subroutine disp_tv_cpld
+ IF (PRESENT(fmt_imag)) THEN
+ IF (.NOT. PRESENT(fmt)) THEN
+ CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN;
+ END IF
+ CALL get_SE(SEim, title, SHAPE(x), fmt_imag)
+ ELSE
+ SEim = SE
+ END IF
+ IF (SE%row) THEN
+ CALL disp_cpld(title, RESHAPE(x, (/1, SIZE(x)/)), SE, SEim, n=SIZE(x))
+ ELSE
+ CALL disp_cpld(title, RESHAPE(x, (/SIZE(x), 1/)), SE, SEim, n=1)
+ END IF
+END SUBROUTINE disp_tv_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
subroutine disp_tm_cpld(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
- ! dbleruple precision complex matrix with title
- character(*), intent(in) :: title ! The title to use for the matrix
- complex(dble), intent(in) :: x(:,:) ! The matrix to be written
- character(*), intent(in), optional :: fmt ! Edit descriptor for each element (real element when fmt_imag &
- ! ! is present)
- character(*), intent(in), optional :: fmt_imag ! Edit descriptor for each imaginary element
- integer, intent(in), optional :: unit ! Unit to display on
- integer, intent(in), optional :: digmax ! Nbr of significant digits for largest abs value in real(x) &
- ! ! and aimag(x)
- character(*), intent(in), optional :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
- character(*), intent(in), optional :: sep ! Separator between matrix columns (e.g. ", ")
- character(*), intent(in), optional :: style ! Style(s): See NOTE 1 below
- character(*), intent(in), optional :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
- ! ! trimming, 'yes' for trimming
- integer, intent(in), optional :: lbound(:) ! Lower bounds of x
- !
- type(settings) :: SE, SEim
+ ! dbleruple precision complex matrix with title
+ CHARACTER(*), INTENT(in) :: title ! The title to use for the matrix
+ COMPLEX(dble), INTENT(in) :: x(:, :) ! The matrix to be written
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt ! Edit descriptor for each element (real element when fmt_imag &
+ ! ! is present)
+ CHARACTER(*), INTENT(in), OPTIONAL :: fmt_imag ! Edit descriptor for each imaginary element
+ INTEGER, INTENT(in), OPTIONAL :: unit ! Unit to display on
+ INTEGER, INTENT(in), OPTIONAL :: digmax ! Nbr of significant digits for largest abs value in real(x) &
+ ! ! and aimag(x)
+ CHARACTER(*), INTENT(in), OPTIONAL :: advance ! 'No' to print next matrix to right of current, otherewise 'Yes'
+ CHARACTER(*), INTENT(in), OPTIONAL :: sep ! Separator between matrix columns (e.g. ", ")
+ CHARACTER(*), INTENT(in), OPTIONAL :: style ! Style(s): See NOTE 1 below
+ CHARACTER(*), INTENT(in), OPTIONAL :: trim ! 'Auto' (the default) to trim if fmt absent, 'no' for no
+ ! ! trimming, 'yes' for trimming
+ INTEGER, INTENT(in), OPTIONAL :: LBOUND(:) ! Lower bounds of x
+ !
+ TYPE(settings) :: SE, SEim
call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax)
- if (present(fmt_imag)) then
- if (.not.present(fmt)) then
- call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return
- endif
- call get_SE(SEim, title, shape(x), fmt_imag)
- else
- SEim = SE
- end if
- call disp_cpld(title, x, SE, SEim, n = size(x,2))
- end subroutine disp_tm_cpld
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
- subroutine disp_cpld(title, x, SE, SEim, n)
- ! dbleruple precision item
- character(*), intent(in) :: title
- complex(dble), intent(in) :: x(:,:)
- type(settings), intent(INOUT ) :: SE, SEim
- integer, intent(in) :: n
- integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n)
- call find_editdesc_dble(real(x), SE, widre, nblre) ! determine also SE%w
- call find_editdesc_dble(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim%w
+ IF (PRESENT(fmt_imag)) THEN
+ IF (.NOT. PRESENT(fmt)) THEN
+ CALL disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); RETURN
+ END IF
+ CALL get_SE(SEim, title, SHAPE(x), fmt_imag)
+ ELSE
+ SEim = SE
+ END IF
+ CALL disp_cpld(title, x, SE, SEim, n=SIZE(x, 2))
+END SUBROUTINE disp_tm_cpld
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE disp_cpld(title, x, SE, SEim, n)
+ ! dbleruple precision item
+ CHARACTER(*), INTENT(in) :: title
+ COMPLEX(dble), INTENT(in) :: x(:, :)
+ TYPE(settings), INTENT(INOUT) :: SE, SEim
+ INTEGER, INTENT(in) :: n
+ INTEGER, DIMENSION(n) :: widre(n), widim(n), nblre(n), nblim(n)
+ CALL find_editdesc_dble(REAL(x), SE, widre, nblre) ! determine also SE%w
+ CALL find_editdesc_dble(ABS(AIMAG(x)), SEim, widim, nblim) ! determine also SEim%w
call tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2))
- end subroutine disp_cpld
+END SUBROUTINE disp_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- subroutine tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
- ! Write dbleruple precision complex matrix to box
- character(*), intent(in) :: title
- complex(dble), intent(in) :: x(:,:)
- integer, intent(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:)
- type(settings), intent(INOUT ) :: SE, SEim
- character(SE%w) :: s(m)
- character(SEim%w) :: sim(m)
- character(3) :: sgn(m)
- integer :: lin1, i, j, wleft, wid(n), widp(n)
- character, pointer :: boxp(:,:)
- SE%zas = ''
- SEim%zas = ''
- wid = widre + widim + 4
- call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
- do j=1,n
- if (m > 0) write(s, SE%ed) (real(x(i,j)), i=1,m)
+SUBROUTINE tobox_cpld(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
+ ! Write dbleruple precision complex matrix to box
+ CHARACTER(*), INTENT(in) :: title
+ COMPLEX(dble), INTENT(in) :: x(:, :)
+ INTEGER, INTENT(in) :: m, n, widre(:), widim(:), nblre(:), nblim(:)
+ TYPE(settings), INTENT(INOUT) :: SE, SEim
+ CHARACTER(SE%w) :: s(m)
+ CHARACTER(SEim%w) :: sim(m)
+ CHARACTER(3) :: sgn(m)
+ INTEGER :: lin1, i, j, wleft, wid(n), widp(n)
+ CHARACTER, POINTER :: boxp(:, :)
+ SE%zas = ''
+ SEim%zas = ''
+ wid = widre + widim + 4
+ CALL preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
+ DO j = 1, n
+ IF (m > 0) WRITE (s, SE%ed) (REAL(x(i, j)), i=1, m)
call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp, wleft)
- do i=1,m
- if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif
- enddo
- call copytobox(sgn, lin1, 3, 3, 0, boxp, wleft)
- if (m > 0) write(sim, SEim%ed) (abs(aimag(x(i,j))), i=1,m)
- call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft)
- call copyseptobox('i', m, lin1, boxp, wleft)
- if (j 0) WRITE (sim, SEim%ed) (ABS(AIMAG(x(i, j))), i=1, m)
+ CALL copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp, wleft)
+ CALL copyseptobox('i', m, lin1, boxp, wleft)
+ IF (j < n) CALL copyseptobox(SE%sep(1:SE%lsep), m, lin1, boxp, wleft)
+ END DO
+ CALL finishbox(title, SE, boxp)
+END SUBROUTINE tobox_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- function tostring_s_cpld(x) result(st)
- complex(dble), intent(in) :: x
- character(len_s_cpld(x, tosset0%rfmt)) :: st
- st = tostring_f_cpld((/x/), tosset0%rfmt)
- end function tostring_s_cpld
+FUNCTION tostring_s_cpld(x) RESULT(st)
+ COMPLEX(dble), INTENT(in) :: x
+ CHARACTER(len_s_cpld(x, tosset0%rfmt)) :: st
+ st = tostring_f_cpld((/x/), tosset0%rfmt)
+END FUNCTION tostring_s_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- function tostring_sf_cpld(x, fmt) result(st)
- complex(dble), intent(in) :: x
- character(*), intent(in) :: fmt
- character(len_s_cpld(x, fmt)) :: st
- st = tostring_f_cpld((/x/), fmt)
- end function tostring_sf_cpld
+FUNCTION tostring_sf_cpld(x, fmt) RESULT(st)
+ COMPLEX(dble), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_s_cpld(x, fmt)) :: st
+ st = tostring_f_cpld((/x/), fmt)
+END FUNCTION tostring_sf_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- function tostring_cpld(x) result(st)
- complex(dble), intent(in) :: x(:)
- character(len_f_cpld(x, tosset0%rfmt)) :: st
- st = tostring_f_cpld(x, tosset0%rfmt)
- end function tostring_cpld
+FUNCTION tostring_cpld(x) RESULT(st)
+ COMPLEX(dble), INTENT(in) :: x(:)
+ CHARACTER(len_f_cpld(x, tosset0%rfmt)) :: st
+ st = tostring_f_cpld(x, tosset0%rfmt)
+END FUNCTION tostring_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- function tostring_f_cpld(x, fmt) result(st)
- complex(dble), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- character(len_f_cpld(x, fmt)) :: st
- character(widthmax_dble(real(x), fmt)) :: sar(size(x))
- character(widthmax_dble(abs(x-real(x)), fmt)) :: sai(size(x)) ! x-real(x) instead of aimag(x) to enable the fnction
- character(1) :: sgn(size(x)) ! to pass -stand:f95 switch of the ifort compiler.
- integer :: w, d, wr, wi, i
- logical :: gedit
- character(nnblk(fmt)+8) :: fmt1 !(5 for readfmt and 3 for replace_w)
- real(dble) :: xre(size(x)), xim(size(x)), h
- call readfmt(fmt, fmt1, w, d, gedit)
- xre = real(x)
- xim = aimag(x)
- h = huge(h)
- if (w < 0) then
- st = errormsg
- return
- elseif (w == 0) then
- wr = maxw_dble(xre, d)
- wi = maxw_dble(xim, d)
- call replace_w(fmt1, max(wr, wi))
- endif
- write(sar, fmt1) real(x)
- write(sai, fmt1) abs(aimag(x))
- call trim_real(sar, gedit, w)
- call trim_real(sai, gedit, w)
- do i = 1,size(x); if (aimag(x(i)) < 0) then; sgn(i) = '-'; else; sgn(i) = '+'; endif; enddo
- call tostring_get_complex(sar, sgn, sai, st)
- end function tostring_f_cpld
+FUNCTION tostring_f_cpld(x, fmt) RESULT(st)
+ COMPLEX(dble), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ CHARACTER(len_f_cpld(x, fmt)) :: st
+ CHARACTER(widthmax_dble(REAL(x), fmt)) :: sar(SIZE(x))
+ CHARACTER(widthmax_dble(ABS(x - REAL(x)), fmt)) :: sai(SIZE(x)) ! x-real(x) instead of aimag(x) to enable the fnction
+ CHARACTER(1) :: sgn(SIZE(x)) ! to pass -stand:f95 switch of the ifort compiler.
+ INTEGER :: w, d, wr, wi, i
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1 !(5 for readfmt and 3 for replace_w)
+ REAL(dble) :: xre(SIZE(x)), xim(SIZE(x)), h
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ xre = REAL(x)
+ xim = AIMAG(x)
+ h = HUGE(h)
+ IF (w < 0) THEN
+ st = errormsg
+ RETURN
+ ELSEIF (w == 0) THEN
+ wr = maxw_dble(xre, d)
+ wi = maxw_dble(xim, d)
+ CALL replace_w(fmt1, MAX(wr, wi))
+ END IF
+ WRITE (sar, fmt1) REAL(x)
+ WRITE (sai, fmt1) ABS(AIMAG(x))
+ CALL trim_real(sar, gedit, w)
+ CALL trim_real(sai, gedit, w)
+ DO i = 1, SIZE(x); IF (AIMAG(x(i)) < 0) THEN; sgn(i) = '-'; ELSE; sgn(i) = '+'; END IF; END DO
+ CALL tostring_get_complex(sar, sgn, sai, st)
+END FUNCTION tostring_f_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- pure function len_s_cpld(x, fmt) result(wtot)
- complex(dble), intent(in) :: x
- character(*), intent(in) :: fmt
- integer :: wtot, w, d
- logical :: gedit
- character(nnblk(fmt)+8) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- wtot = len_f_dble((/real(x)/), fmt) + len_f_dble((/abs(aimag(x))/), fmt) + 4
- end function len_s_cpld
+PURE FUNCTION len_s_cpld(x, fmt) RESULT(wtot)
+ COMPLEX(dble), INTENT(in) :: x
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ wtot = len_f_dble((/REAL(x)/), fmt) + len_f_dble((/ABS(AIMAG(x))/), fmt) + 4
+END FUNCTION len_s_cpld
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
- pure function len_f_cpld(x, fmt) result(wtot)
- complex(dble), intent(in) :: x(:)
- character(*), intent(in) :: fmt
- integer :: wtot, w, d
- logical :: gedit
- character(nnblk(fmt)+8) :: fmt1
- call readfmt(fmt, fmt1, w, d, gedit)
- if (w < 0) then; wtot = len(errormsg); return; endif
- wtot = len_f_dble(real(x), fmt) + len_f_dble(abs(aimag(x)), fmt) &
- & + size(x)*4 - (size(x) - 1)*(tosset0%seplen)
- ! subtract seplen because it has been added twice in len_f_dble
- end function len_f_cpld
+PURE FUNCTION len_f_cpld(x, fmt) RESULT(wtot)
+ COMPLEX(dble), INTENT(in) :: x(:)
+ CHARACTER(*), INTENT(in) :: fmt
+ INTEGER :: wtot, w, d
+ LOGICAL :: gedit
+ CHARACTER(nnblk(fmt) + 8) :: fmt1
+ CALL readfmt(fmt, fmt1, w, d, gedit)
+ IF (w < 0) THEN; wtot = LEN(errormsg); RETURN; END IF
+ wtot = len_f_dble(REAL(x), fmt) + len_f_dble(ABS(AIMAG(x)), fmt) &
+ & + SIZE(x) * 4 - (SIZE(x) - 1) * (tosset0%seplen)
+ ! subtract seplen because it has been added twice in len_f_dble
+END FUNCTION len_f_cpld
END MODULE DISP_R8MOD
diff --git a/src/modules/Display/src/disp/putstrmodule.F90 b/src/modules/Display/src/disp/putstrmodule.F90
index 62823a946..2be3ccc06 100644
--- a/src/modules/Display/src/disp/putstrmodule.F90
+++ b/src/modules/Display/src/disp/putstrmodule.F90
@@ -1,25 +1,25 @@
MODULE PUTSTRMODULE ! DUMMY VERSION
- ! An auxilliary module that accompanies DISPMODULE. This module contains dummy versions of the
- ! subroutines putstr and putnl that do nothing. It is needed to avoid an "undefined symbol" link
- ! error for these. In addition it defines the named constant (or parameter) DEFAULT_UNIT = -3,
- ! which makes the asterisk unit (usually the screen) the default to display on.
- !
- ! The purpose of having this module is to make displaying possible in situations where ordinary
- ! print- and write-statements do not work. Then this module should be replaced by one defining
- ! functional versions of putstr and putnl. An example is given by the commented out PUTSTRMODULE
- ! for Matlab mex files below.
- !
- integer, parameter :: DEFAULT_UNIT = -3
- !
+! An auxilliary module that accompanies DISPMODULE. This module contains dummy versions of the
+! subroutines putstr and putnl that do nothing. It is needed to avoid an "undefined symbol" link
+! error for these. In addition it defines the named constant (or parameter) DEFAULT_UNIT = -3,
+! which makes the asterisk unit (usually the screen) the default to display on.
+!
+! The purpose of having this module is to make displaying possible in situations where ordinary
+! print- and write-statements do not work. Then this module should be replaced by one defining
+! functional versions of putstr and putnl. An example is given by the commented out PUTSTRMODULE
+! for Matlab mex files below.
+!
+INTEGER, PARAMETER :: DEFAULT_UNIT = -3
+!
CONTAINS
- subroutine putstr(s)
- character(*), intent(in) :: s
- integer ldummy, ldummy1 ! these variables exist to avoid unused variable warnings
- ldummy = len(s)
- ldummy1 = ldummy
- ldummy = ldummy1
- end subroutine putstr
+SUBROUTINE putstr(s)
+ CHARACTER(*), INTENT(in) :: s
+ INTEGER ldummy, ldummy1 ! these variables exist to avoid unused variable warnings
+ ldummy = LEN(s)
+ ldummy1 = ldummy
+ ldummy = ldummy1
+END SUBROUTINE putstr
- subroutine putnl()
- end subroutine putnl
+SUBROUTINE putnl()
+END SUBROUTINE putnl
END MODULE PUTSTRMODULE
diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt
index 39fa1ba47..1ce516e03 100644
--- a/src/modules/ElemshapeData/CMakeLists.txt
+++ b/src/modules/ElemshapeData/CMakeLists.txt
@@ -1,43 +1,43 @@
-# This program is a part of EASIFEM library
-# Copyright (C) 2020-2021 Vikas Sharma, Ph.D
+# 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 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.
+# 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
+# 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}/ElemshapeData_Method.F90
- ${src_path}/ElemshapeData_ConstructorMethods.F90
- ${src_path}/ElemshapeData_DivergenceMethods.F90
- ${src_path}/ElemshapeData_GradientMethods.F90
- ${src_path}/ElemshapeData_GetMethods.F90
-
- ${src_path}/ElemshapeData_H1Methods.F90
- ${src_path}/ElemshapeData_DGMethods.F90
- ${src_path}/ElemshapeData_HDivMethods.F90
- ${src_path}/ElemshapeData_HCurlMethods.F90
-
- ${src_path}/ElemshapeData_HminHmaxMethods.F90
- ${src_path}/ElemshapeData_HRGNParamMethods.F90
- ${src_path}/ElemshapeData_HRQIParamMethods.F90
- ${src_path}/ElemshapeData_InterpolMethods.F90
- ${src_path}/ElemshapeData_IOMethods.F90
- ${src_path}/ElemshapeData_LocalDivergenceMethods.F90
- ${src_path}/ElemshapeData_LocalGradientMethods.F90
- ${src_path}/ElemshapeData_ProjectionMethods.F90
- ${src_path}/ElemshapeData_SetMethods.F90
- ${src_path}/ElemshapeData_StabilizationParamMethods.F90
- ${src_path}/ElemshapeData_UnitNormalMethods.F90
-)
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ElemshapeData_Method.F90
+ ${src_path}/ElemshapeData_ConstructorMethods.F90
+ ${src_path}/ElemshapeData_DivergenceMethods.F90
+ ${src_path}/ElemshapeData_GradientMethods.F90
+ ${src_path}/ElemshapeData_GetMethods.F90
+ # ${src_path}/ElemshapeData_H1Methods.F90
+ # ${src_path}/ElemshapeData_DGMethods.F90
+ # ${src_path}/ElemshapeData_HDivMethods.F90
+ # ${src_path}/ElemshapeData_HCurlMethods.F90
+ ${src_path}/ElemshapeData_Lagrange.F90
+ ${src_path}/ElemshapeData_Hierarchical.F90
+ ${src_path}/ElemshapeData_Orthogonal.F90
+ ${src_path}/ElemshapeData_HminHmaxMethods.F90
+ ${src_path}/ElemshapeData_HRGNParamMethods.F90
+ ${src_path}/ElemshapeData_HRQIParamMethods.F90
+ ${src_path}/ElemshapeData_InterpolMethods.F90
+ ${src_path}/ElemshapeData_IOMethods.F90
+ ${src_path}/ElemshapeData_LocalDivergenceMethods.F90
+ ${src_path}/ElemshapeData_LocalGradientMethods.F90
+ ${src_path}/ElemshapeData_ProjectionMethods.F90
+ ${src_path}/ElemshapeData_SetMethods.F90
+ ${src_path}/ElemshapeData_StabilizationParamMethods.F90
+ ${src_path}/ElemshapeData_UnitNormalMethods.F90)
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90
index e740cd001..48406b880 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90
@@ -40,7 +40,7 @@ MODULE ElemshapeData_ConstructorMethods
!- This subroutine belongs to the generic interface called `Allocate()`.
INTERFACE ALLOCATE
- MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips)
+ MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips, nnt)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! object to be returned
INTEGER(I4B), INTENT(IN) :: nsd
@@ -51,6 +51,8 @@ MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips)
!! number of nodes in element
INTEGER(I4B), INTENT(IN) :: nips
!! number of integration points
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnt
+ !! it is used when elemshape data is STElemShapeData
END SUBROUTINE elemsd_Allocate
END INTERFACE ALLOCATE
@@ -60,11 +62,11 @@ END SUBROUTINE elemsd_Allocate
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiate the element shapefunction data
+! summary: This routine Initiate the element shapefunction data
INTERFACE Initiate
- MODULE SUBROUTINE elemsd_initiate1(obj, quad, refelem, continuityType, &
- & interpolType)
+ MODULE SUBROUTINE elemsd_Initiate1(obj, quad, refelem, continuityType, &
+ interpolType)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! ElemshapeData to be formed
CLASS(QuadraturePoint_), INTENT(IN) :: quad
@@ -75,7 +77,7 @@ MODULE SUBROUTINE elemsd_initiate1(obj, quad, refelem, continuityType, &
!! - continuity/ conformity of shape function (basis functions)
CHARACTER(*), INTENT(IN) :: interpolType
!! interpolation/polynomial family for basis functions
- END SUBROUTINE elemsd_initiate1
+ END SUBROUTINE elemsd_Initiate1
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -87,85 +89,14 @@ END SUBROUTINE elemsd_initiate1
! summary: Copy data from an instance of elemshapedata to another instance
INTERFACE Initiate
- MODULE SUBROUTINE elemsd_initiate2(obj1, obj2)
- TYPE(ElemshapeData_), INTENT(INOUT) :: obj1
- TYPE(ElemshapeData_), INTENT(IN) :: obj2
- END SUBROUTINE elemsd_initiate2
+ MODULE SUBROUTINE elemsd_Initiate2(obj1, obj2)
+ CLASS(ElemshapeData_), INTENT(INOUT) :: obj1
+ CLASS(ElemshapeData_), INTENT(IN) :: obj2
+ END SUBROUTINE elemsd_Initiate2
END INTERFACE Initiate
INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE elemsd_initiate2
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! Initiate@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 20 May 2022
-! summary: Initiate an instance of ElemshapeData from STElemshapeData
-!
-!# Introduction
-!
-! This subroutine initiates an instance of ElemshapeData by copying data
-! from an instance of STElemshapeData.
-
-INTERFACE Initiate
- MODULE SUBROUTINE elemsd_initiate3(obj1, obj2)
- TYPE(ElemshapeData_), INTENT(INOUT) :: obj1
- TYPE(STElemshapeData_), INTENT(IN) :: obj2
- END SUBROUTINE elemsd_initiate3
-END INTERFACE Initiate
-
-INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE elemsd_initiate3
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! Initiate@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 20 May 2022
-! summary: This routine initiates an instance of STElemshapeData
-!
-!# Introduction
-!
-! This routine initiate an instance of STElemshapeData by copying data
-! from the instance of ElemshapeData
-
-INTERFACE Initiate
- MODULE SUBROUTINE elemsd_initiate4(obj1, obj2)
- TYPE(STElemshapeData_), INTENT(INOUT) :: obj1
- TYPE(ElemshapeData_), INTENT(IN) :: obj2
- END SUBROUTINE elemsd_initiate4
-END INTERFACE Initiate
-
-INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE elemsd_initiate4
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! Initiate@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 20 May 2022
-! summary: Initiate an instance of STElemshapeData from instance of same class
-!
-!# Introduction
-! This routine initiates an instance of STElemshapeData by copying data
-! from the instance of STElemshapeData.
-
-INTERFACE Initiate
- MODULE SUBROUTINE elemsd_initiate5(obj1, obj2)
- TYPE(STElemshapeData_), INTENT(INOUT) :: obj1
- TYPE(STElemshapeData_), INTENT(IN) :: obj2
- END SUBROUTINE elemsd_initiate5
-END INTERFACE Initiate
-
-INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE elemsd_initiate5
+ MODULE PROCEDURE elemsd_Initiate2
END INTERFACE
!----------------------------------------------------------------------------
@@ -178,7 +109,7 @@ END SUBROUTINE elemsd_initiate5
!
!# Introduction
!
-! - This subroutine initiates the shape-function data related to time
+! - This subroutine Initiates the shape-function data related to time
! domain in the instance of [[stelemshapedata_]].
! - User should provide an instance of [[Elemshapedata_]] elemsd,
! - The `elemsd`, actually contains the information of
@@ -194,11 +125,11 @@ END SUBROUTINE elemsd_initiate5
!
INTERFACE Initiate
- MODULE PURE SUBROUTINE stsd_initiate(obj, elemsd)
+ MODULE PURE SUBROUTINE stsd_Initiate(obj, elemsd)
TYPE(STElemshapeData_), ALLOCATABLE, INTENT(INOUT) :: obj(:)
TYPE(ElemshapeData_), INTENT(IN) :: elemsd
!! It has information about location shape function for time element
- END SUBROUTINE stsd_initiate
+ END SUBROUTINE stsd_Initiate
END INTERFACE Initiate
!----------------------------------------------------------------------------
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90
index a22cb4207..141b2dea2 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_DivergenceMethods.F90
@@ -15,17 +15,19 @@
! along with this program. If not, see
!
-module ElemshapeData_DivergenceMethods
-USE BaseType
-USE GlobalData
+MODULE ElemshapeData_DivergenceMethods
+USE BaseType, ONLY: ElemShapeData_, STElemshapeData_, FEVariable_
+USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
+
PRIVATE
-PUBLIC :: getDivergence
+PUBLIC :: GetDivergence
PUBLIC :: Divergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -33,47 +35,45 @@ module ElemshapeData_DivergenceMethods
! update: 2021-11-26
! summary: This subroutine returns the Divergence of a vector
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_1(obj, lg, val)
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_1(obj, val, ans, tsize)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:)
- !! Divergence at integration points
REAL(DFP), INTENT(IN) :: val(:, :)
!! space nodal values of vector in `xiJ` format
!! row index: space component
!! col index: node number
- END SUBROUTINE elemsd_getDivergence_1
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_1
-END INTERFACE getDivergence
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Divergence at integration points
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! size of ans
+ END SUBROUTINE elemsd_GetDivergence_1
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2021-11-26
! update: 2021-11-26
! summary: This subroutine returns the Divergence of a vector
-!
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_2(obj, lg, val)
+
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_2(obj, val, ans, tsize)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:)
- !! Divergence at integration points
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! space-time nodal values of vector in `xiJa` format
- END SUBROUTINE elemsd_getDivergence_2
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_2
-END INTERFACE getDivergence
+ !! spaceComponent
+ !! number of nodes in space
+ !! number of nodes in time
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Divergence at integration points
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE elemsd_GetDivergence_2
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -81,22 +81,20 @@ END SUBROUTINE elemsd_getDivergence_2
! update: 2021-11-26
! summary: This subroutine returns the Divergence of a vector
!
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_3(obj, lg, val)
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_3(obj, val, ans, tsize)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:)
- !! Divergence of vector at integration points
TYPE(FEVariable_), INTENT(IN) :: val
!! vector finite-element variable
- END SUBROUTINE elemsd_getDivergence_3
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_3
-END INTERFACE getDivergence
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Divergence of vector at integration points
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size of ans
+ END SUBROUTINE elemsd_GetDivergence_3
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -104,22 +102,22 @@ END SUBROUTINE elemsd_getDivergence_3
! update: 2021-11-26
! summary: This subroutine returns the Divergence of a matrix
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_4(obj, lg, val)
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_4(obj, val, ans, nrow, ncol)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :)
- !! Divergence at integration points
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! space nodal values of matrix in (i,j,I) format
- END SUBROUTINE elemsd_getDivergence_4
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_4
-END INTERFACE getDivergence
+ !! dim1 = component
+ !! dim2 = component
+ !! dim3 = nns
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Divergence at integration points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE elemsd_GetDivergence_4
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -127,22 +125,20 @@ END SUBROUTINE elemsd_getDivergence_4
! update: 2021-11-26
! summary: This subroutine returns the Divergence of a vector
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_5(obj, lg, val)
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_5(obj, val, ans, nrow, ncol)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :)
- !! Divergence at integration points
REAL(DFP), INTENT(IN) :: val(:, :, :, :)
!! space-time nodal values of matrix in (i,j,I,a) format
- END SUBROUTINE elemsd_getDivergence_5
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_5
-END INTERFACE getDivergence
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Divergence at integration points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns of ans
+ END SUBROUTINE elemsd_GetDivergence_5
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -150,44 +146,38 @@ END SUBROUTINE elemsd_getDivergence_5
! update: 2021-11-26
! summary: This subroutine returns the Divergence of a vector
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_6(obj, lg, val)
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_6(obj, val, ans, nrow, ncol)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: lg(:, :)
- !! Divergence at integration points
TYPE(FEVariable_), INTENT(IN) :: val
!! space/space-time nodal values of matrix in (i,j,I) format
- END SUBROUTINE elemsd_getDivergence_6
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_6
-END INTERFACE getDivergence
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Divergence at integration points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns of ans
+ END SUBROUTINE elemsd_GetDivergence_6
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2021-11-26
! update: 2021-11-26
! summary: This subroutine returns the Divergence
-!
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_7(obj, lg, val)
+
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_7(obj, val, ans)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- TYPE(FEVariable_), INTENT(INOUT) :: lg
- !! Divergence of scalar/vector/matrix at space integration points
TYPE(FEVariable_), INTENT(IN) :: val
- END SUBROUTINE elemsd_getDivergence_7
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_7
-END INTERFACE getDivergence
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Divergence of scalar/vector/matrix at space integration points
+ END SUBROUTINE elemsd_GetDivergence_7
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
-! getDivergence@DivergenceMethods
+! GetDivergence@DivergenceMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -195,51 +185,43 @@ END SUBROUTINE elemsd_getDivergence_7
! update: 2021-11-26
! summary: This subroutine returns the Divergence
-INTERFACE
- MODULE PURE SUBROUTINE elemsd_getDivergence_8(obj, lg, val)
+INTERFACE GetDivergence
+ MODULE PURE SUBROUTINE elemsd_GetDivergence_8(obj, val, ans)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- TYPE(FEVariable_), INTENT(INOUT) :: lg
- !! Divergence of scalar/vector/matrix at space-time
- !! integration points
TYPE(FEVariable_), INTENT(IN) :: val
!! space time nodal values of scalar/vector/matrix
- END SUBROUTINE elemsd_getDivergence_8
-END INTERFACE
-
-INTERFACE getDivergence
- MODULE PROCEDURE elemsd_getDivergence_8
-END INTERFACE getDivergence
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Divergence of scalar/vector/matrix at space-time
+ !! integration points
+ END SUBROUTINE elemsd_GetDivergence_8
+END INTERFACE GetDivergence
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE Divergence
MODULE PURE FUNCTION elemsd_Divergence_1(obj, val) RESULT(Ans)
CLASS(ElemshapeData_), INTENT(IN) :: obj
TYPE(FEVariable_), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
END FUNCTION elemsd_Divergence_1
-END INTERFACE
-
-INTERFACE Divergence
- MODULE PROCEDURE elemsd_Divergence_1
END INTERFACE Divergence
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE Divergence
MODULE PURE FUNCTION elemsd_Divergence_2(obj, val) RESULT(Ans)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
TYPE(FEVariable_), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
END FUNCTION elemsd_Divergence_2
-END INTERFACE
-
-INTERFACE Divergence
- MODULE PROCEDURE elemsd_Divergence_2
END INTERFACE Divergence
-end module ElemshapeData_DivergenceMethods
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE ElemshapeData_DivergenceMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90
index 084e82e6a..373e1bb72 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_GetMethods.F90
@@ -15,13 +15,15 @@
! along with this program. If not, see
!
-module ElemshapeData_GetMethods
-USE BaseType
-USE GlobalData
+MODULE ElemshapeData_GetMethods
+USE BaseType, ONLY: ElemshapeData_, STElemshapeData_, FEVariable_
+
+USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
PRIVATE
-PUBLIC :: getNormal
+PUBLIC :: GetNormal
!----------------------------------------------------------------------------
! GetNormal
@@ -32,18 +34,14 @@ module ElemshapeData_GetMethods
! update: 28 Jan 2022
! summary: This routine returns the normal vector stored in [[ElemShapeData_]]
-INTERFACE
+INTERFACE GetNormal
MODULE PURE SUBROUTINE elemsd_getNormal_1(obj, normal, nsd)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: normal(:, :)
!! normal(1:3, 1:nip) = obj%normal
INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd
END SUBROUTINE elemsd_getNormal_1
-END INTERFACE
-
-INTERFACE getNormal
- MODULE PROCEDURE elemsd_getNormal_1
-END INTERFACE getNormal
+END INTERFACE GetNormal
!----------------------------------------------------------------------------
! GetNormal
@@ -54,7 +52,7 @@ END SUBROUTINE elemsd_getNormal_1
! update: 28 Jan 2022
! summary: This routine returns the normal vector stored in [[ElemShapeData_]]
-INTERFACE
+INTERFACE GetNormal
MODULE PURE SUBROUTINE elemsd_getNormal_2(obj, normal, nsd)
CLASS(ElemshapeData_), INTENT(IN) :: obj
TYPE(FEVariable_), INTENT(INOUT) :: normal
@@ -62,11 +60,7 @@ MODULE PURE SUBROUTINE elemsd_getNormal_2(obj, normal, nsd)
!! Quadrature, Vector, Space
INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd
END SUBROUTINE elemsd_getNormal_2
-END INTERFACE
-
-INTERFACE getNormal
- MODULE PROCEDURE elemsd_getNormal_2
-END INTERFACE getNormal
+END INTERFACE GetNormal
!----------------------------------------------------------------------------
! GetNormal
@@ -77,7 +71,7 @@ END SUBROUTINE elemsd_getNormal_2
! update: 28 Jan 2022
! summary: This routine returns the normal vector stored in [[ElemShapeData_]]
-INTERFACE
+INTERFACE GetNormal
MODULE PURE SUBROUTINE elemsd_getNormal_3(obj, normal, nsd)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
TYPE(FEVariable_), INTENT(INOUT) :: normal
@@ -85,10 +79,6 @@ MODULE PURE SUBROUTINE elemsd_getNormal_3(obj, normal, nsd)
!! Quadrature, Vector, SpaceTime
INTEGER(I4B), OPTIONAL, INTENT(IN) :: nsd
END SUBROUTINE elemsd_getNormal_3
-END INTERFACE
-
-INTERFACE getNormal
- MODULE PROCEDURE elemsd_getNormal_3
-END INTERFACE getNormal
+END INTERFACE GetNormal
-end module ElemshapeData_GetMethods
+END MODULE ElemshapeData_GetMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90
index 2af6c22b6..185537cb6 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_H1Methods.F90
@@ -15,56 +15,23 @@
! along with this program. If not, see
MODULE ElemshapeData_H1Methods
-USE BaseType
-USE GlobalData
-IMPLICIT NONE
-PRIVATE
-PUBLIC :: Initiate
+USE BaseType, ONLY: ElemshapeData_, &
+ QuadraturePoint_, &
+ ReferenceElement_, &
+ H1_, &
+ LagrangeInterpolation_, &
+ HierarchyInterpolation_, &
+ OrthogonalInterpolation_, &
+ HermitInterpolation_, &
+ SerendipityInterpolation_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
-!----------------------------------------------------------------------------
-! Initiate@Methods
-!----------------------------------------------------------------------------
+IMPLICIT NONE
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-08-16
-! summary: This routine initiate the shape data
+PRIVATE
-INTERFACE Initiate
- MODULE SUBROUTINE H1_Lagrange1( &
- & obj, &
- & quad, &
- & refelem, &
- & baseContinuity, &
- & baseInterpolation, &
- & order, &
- & ipType, &
- & basisType, &
- & coeff, &
- & firstCall, &
- & alpha, &
- & beta, &
- & lambda)
- CLASS(ElemshapeData_), INTENT(INOUT) :: obj
- CLASS(QuadraturePoint_), INTENT(IN) :: quad
- CLASS(ReferenceElement_), INTENT(IN) :: refelem
- CLASS(H1_), INTENT(IN) :: baseContinuity
- CLASS(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType
- !! Interpolation point type
- !! Default value is Equidistance
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Basis function types
- !! Default value is Monomial
- REAL(DFP), OPTIONAL, ALLOCATABLE, INTENT(INOUT) :: coeff(:, :)
- !! Coefficient of Lagrange polynomials
- LOGICAL(LGT), OPTIONAL :: firstCall
- !! If firstCall is true, then coeff will be made
- !! If firstCall is False, then coeff will be used
- !! Default value of firstCall is True
- REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
- END SUBROUTINE H1_Lagrange1
-END INTERFACE Initiate
+PUBLIC :: Initiate
!----------------------------------------------------------------------------
! Initiate@H1Hierarchy
@@ -79,17 +46,8 @@ END SUBROUTINE H1_Lagrange1
! This routine initiates the shape function related data inside the element.
INTERFACE Initiate
- MODULE SUBROUTINE H1_Hierarchy1( &
- & obj, &
- & quad, &
- & refelem, &
- & baseContinuity, &
- & baseInterpolation, &
- & order, &
- & ipType, &
- & basisType, &
- & alpha, beta, lambda &
- &)
+ MODULE SUBROUTINE H1_Hierarchy1(obj, quad, refelem, baseContinuity, &
+ baseInterpolation, order, ipType, basisType, alpha, beta, lambda)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! Element shape data
CLASS(QuadraturePoint_), INTENT(IN) :: quad
@@ -128,17 +86,8 @@ END SUBROUTINE H1_Hierarchy1
! This routine initiates the shape function related data inside the element.
INTERFACE Initiate
- MODULE SUBROUTINE H1_Orthogonal1( &
- & obj, &
- & quad, &
- & refelem, &
- & baseContinuity, &
- & baseInterpolation, &
- & order, &
- & ipType, &
- & basisType, &
- & alpha, beta, lambda &
- &)
+ MODULE SUBROUTINE H1_Orthogonal1(obj, quad, refelem, baseContinuity, &
+ baseInterpolation, order, ipType, basisType, alpha, beta, lambda)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! Element shape data
CLASS(QuadraturePoint_), INTENT(IN) :: quad
@@ -174,17 +123,8 @@ END SUBROUTINE H1_Orthogonal1
! This routine initiates the shape function related data inside the element.
INTERFACE Initiate
- MODULE SUBROUTINE H1_Hermit1( &
- & obj, &
- & quad, &
- & refelem, &
- & baseContinuity, &
- & baseInterpolation, &
- & order, &
- & ipType, &
- & basisType, &
- & alpha, beta, lambda &
- &)
+ MODULE SUBROUTINE H1_Hermit1(obj, quad, refelem, baseContinuity, &
+ baseInterpolation, order, ipType, basisType, alpha, beta, lambda)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! Element shape data
CLASS(QuadraturePoint_), INTENT(IN) :: quad
@@ -216,17 +156,8 @@ END SUBROUTINE H1_Hermit1
! summary: This routine initiate the shape data
INTERFACE Initiate
- MODULE SUBROUTINE H1_Serendipity1( &
- & obj, &
- & quad, &
- & refelem, &
- & baseContinuity, &
- & baseInterpolation, &
- & order, &
- & ipType, &
- & basisType, &
- & alpha, beta, lambda &
- &)
+ MODULE SUBROUTINE H1_Serendipity1(obj, quad, refelem, baseContinuity, &
+ baseInterpolation, order, ipType, basisType, alpha, beta, lambda)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! Element shape data
CLASS(QuadraturePoint_), INTENT(IN) :: quad
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90
new file mode 100644
index 000000000..15c3184f6
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90
@@ -0,0 +1,138 @@
+! 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 ElemshapeData_Hierarchical
+USE BaseType, ONLY: ElemshapeData_, &
+ QuadraturePoint_, &
+ ReferenceElement_, &
+ H1_, &
+ HierarchyInterpolation_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: HierarchicalElemShapeData
+PUBLIC :: Initiate
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE HierarchicalElemShapeData
+ MODULE SUBROUTINE HierarchicalElemShapeData1(obj, quad, nsd, xidim, &
+ elemType, refelemCoord, domainName, cellOrder, faceOrder, edgeOrder, &
+ cellOrient, faceOrient, edgeOrient)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj
+ !! element shape data
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ !! quadrature point
+ INTEGER(I4B), INTENT(IN) :: nsd
+ !! number of spatial dimension
+ INTEGER(I4B), INTENT(IN) :: xidim
+ !! dimension of xi
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: refelemCoord(:, :)
+ !! coordinate of reference element
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! name of reference element domain
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+ !! orientation of cell
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :)
+ !! orientation of face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ END SUBROUTINE HierarchicalElemShapeData1
+END INTERFACE HierarchicalElemShapeData
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE HierarchicalElemShapeData
+ MODULE SUBROUTINE HierarchicalElemShapeData2(obj, quad, refelem, cellOrder, &
+ faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ CLASS(ReferenceElement_), INTENT(IN) :: refelem
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+ !! orientation of cell
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :)
+ !! orientation of face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ END SUBROUTINE HierarchicalElemShapeData2
+END INTERFACE HierarchicalElemShapeData
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HierarchicalElemShapeData
+ MODULE SUBROUTINE HierarchicalElemShapeData3(obj, quad, refelem, &
+ baseContinuity, baseInterpolation, cellOrder, &
+ faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ CLASS(ReferenceElement_), INTENT(IN) :: refelem
+ !! reference element
+ TYPE(H1_), INTENT(IN) :: baseContinuity
+ !! base continuity
+ TYPE(HierarchyInterpolation_), INTENT(IN) :: baseInterpolation
+ !! base interpolation
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+ !! orientation of cell
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :)
+ !! orientation of face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ END SUBROUTINE HierarchicalElemShapeData3
+END INTERFACE HierarchicalElemShapeData
+
+INTERFACE Initiate
+ MODULE PROCEDURE HierarchicalElemShapeData3
+END INTERFACE Initiate
+
+END MODULE ElemshapeData_Hierarchical
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90
index 3ddeaf0f5..f2d64dfaa 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_IOMethods.F90
@@ -16,9 +16,12 @@
!
MODULE ElemshapeData_IOMethods
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: ElemshapeData_, STElemShapeData_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
USE String_Class, ONLY: String
+
IMPLICIT NONE
PRIVATE
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90
index 1074afee6..f6ab5ef77 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90
@@ -17,13 +17,14 @@
!
! This file contains the interpolation methods interfaces\
-module ElemshapeData_InterpolMethods
+MODULE ElemshapeData_InterpolMethods
USE BaseType
USE GlobalData
IMPLICIT NONE
PRIVATE
-PUBLIC :: getInterpolation
+PUBLIC :: GetInterpolation
+PUBLIC :: GetInterpolation_
PUBLIC :: Interpolation
PUBLIC :: STInterpolation
@@ -44,7 +45,7 @@ module ElemshapeData_InterpolMethods
!
! - TODO Make it work when the size of val is not the same as NNS
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:)
@@ -52,11 +53,24 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:)
!! spatial nodal values of scalar
END SUBROUTINE scalar_getInterpolation_1
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_1
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE scalar_getInterpolation1_(obj, interpol, val, tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:)
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE scalar_getInterpolation1_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -76,7 +90,7 @@ END SUBROUTINE scalar_getInterpolation_1
! The resultant represents the interpolation value of `val` at
! spatial-quadrature points
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:)
@@ -84,11 +98,20 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :)
!! space-time nodal values of scalar
END SUBROUTINE scalar_getInterpolation_2
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_2
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE scalar_getInterpolation2_(obj, interpol, val, tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE scalar_getInterpolation2_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -108,7 +131,7 @@ END SUBROUTINE scalar_getInterpolation_2
! The resultant represents the interpolation value of `val` at
! spatial-temporal quadrature points
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :)
@@ -116,11 +139,25 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :)
!! space-time nodal values of scalar
END SUBROUTINE scalar_getInterpolation_3
-END INTERFACE
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_3
-END INTERFACE getInterpolation
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE scalar_getInterpolation3_(obj, interpol, val, &
+ nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE scalar_getInterpolation3_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -144,7 +181,7 @@ END SUBROUTINE scalar_getInterpolation_3
!This routine calls [[Interpolation]] function from the same module.
!@endnote
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE scalar_getInterpolation_4(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:)
@@ -152,11 +189,24 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_4(obj, interpol, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! Scalar FE variable
END SUBROUTINE scalar_getInterpolation_4
-END INTERFACE
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_4
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE scalar_getInterpolation4_(obj, interpol, val, tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE scalar_getInterpolation4_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -181,7 +231,7 @@ END SUBROUTINE scalar_getInterpolation_4
! The resultant represents the interpolation value of `val` at
! spatial-quadrature points
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :)
@@ -189,11 +239,25 @@ MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! scalar FE variable
END SUBROUTINE scalar_getInterpolation_5
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_5
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE scalar_getInterpolation5_(obj, interpol, val, &
+ nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE scalar_getInterpolation5_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -210,7 +274,7 @@ END SUBROUTINE scalar_getInterpolation_5
!
! $$u_{i}=u_{iI}N^{I}$$
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :)
@@ -218,11 +282,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :)
!! nodal values of vector in `xiJ` format
END SUBROUTINE vector_getInterpolation_1
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_1
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE vector_getInterpolation1_(obj, interpol, val, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE vector_getInterpolation1_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -239,7 +317,7 @@ END SUBROUTINE vector_getInterpolation_1
!
! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :)
@@ -247,11 +325,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! space-time nodal values of vector in `xiJa` format
END SUBROUTINE vector_getInterpolation_2
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_2
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE vector_getInterpolation2_(obj, interpol, val, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE vector_getInterpolation2_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -268,7 +360,7 @@ END SUBROUTINE vector_getInterpolation_2
!
! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :)
@@ -276,11 +368,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! space-time nodal values of vector in `xiJa` format
END SUBROUTINE vector_getInterpolation_3
-END INTERFACE
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_3
-END INTERFACE getInterpolation
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE vector_getInterpolation3_(obj, interpol, val, &
+ dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE vector_getInterpolation3_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -302,7 +408,7 @@ END SUBROUTINE vector_getInterpolation_3
!
! NOTE This routine calls [[Interpolation]] function from the same module.
!
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :)
@@ -310,11 +416,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! vector FEvariable
END SUBROUTINE vector_getInterpolation_4
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_4
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE vector_getInterpolation4_(obj, interpol, val, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE vector_getInterpolation4_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -336,7 +456,7 @@ END SUBROUTINE vector_getInterpolation_4
!
! NOTE This routine calls [[Interpolation]] function from the same module.
!
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :)
@@ -344,11 +464,25 @@ MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! vector FEvariable
END SUBROUTINE vector_getInterpolation_5
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_5
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE vector_getInterpolation5_(obj, interpol, val, &
+ dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE vector_getInterpolation5_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -358,7 +492,7 @@ END SUBROUTINE vector_getInterpolation_5
! date: 4 March 2021
! summary: This subroutine performs interpolation of matrix
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :)
@@ -366,11 +500,25 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! nodal value of matrix
END SUBROUTINE matrix_getInterpolation_1
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_1
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE matrix_getInterpolation1_(obj, interpol, val, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matrix_getInterpolation1_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -385,18 +533,32 @@ END SUBROUTINE matrix_getInterpolation_1
! This subroutine performs interpolation of matrix from its space-time
! nodal values
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE matrix_getInterpolation_2(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :)
REAL(DFP), INTENT(IN) :: val(:, :, :, :)
!! space-time nodal value of matrix
END SUBROUTINE matrix_getInterpolation_2
-END INTERFACE
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_2
-END INTERFACE getInterpolation
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE matrix_getInterpolation2_(obj, interpol, val, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matrix_getInterpolation2_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -411,7 +573,7 @@ END SUBROUTINE matrix_getInterpolation_2
! This subroutine performs interpolation of matrix from its space-time
! nodal values
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :)
@@ -419,11 +581,7 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val)
REAL(DFP), INTENT(IN) :: val(:, :, :, :)
!! space-time nodal value of matrix
END SUBROUTINE matrix_getInterpolation_3
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_3
-END INTERFACE getInterpolation
+END INTERFACE GetInterpolation
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -433,7 +591,7 @@ END SUBROUTINE matrix_getInterpolation_3
! date: 4 March 2021
! summary: This subroutine performs interpolation of matrix FEVariable
!
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :)
@@ -441,17 +599,31 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! matrix fe variable
END SUBROUTINE matrix_getInterpolation_4
-END INTERFACE
+END INTERFACE GetInterpolation
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_4
-END INTERFACE getInterpolation
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE matrix_getInterpolation4_(obj, interpol, val, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matrix_getInterpolation4_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :)
@@ -459,11 +631,25 @@ MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! matrix fe variable
END SUBROUTINE matrix_getInterpolation_5
-END INTERFACE
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_5
-END INTERFACE getInterpolation
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE matrix_getInterpolation5_(obj, interpol, val, &
+ dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: interpol(:, :, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE matrix_getInterpolation5_
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -485,17 +671,13 @@ END SUBROUTINE matrix_getInterpolation_5
! - the val can be defined on quadrature (do nothing) or nodal (interpol)
! - The `vartype` of val can be constant, space, time, spacetime
!
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
TYPE(FEVariable_), INTENT(INOUT) :: interpol
TYPE(FEVariable_), INTENT(IN) :: val
END SUBROUTINE master_getInterpolation_1
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE master_getInterpolation_1
-END INTERFACE getInterpolation
+END INTERFACE GetInterpolation
!----------------------------------------------------------------------------
! getInterpolation@InterpolMethods
@@ -517,17 +699,13 @@ END SUBROUTINE master_getInterpolation_1
! - the val can be defined on quadrature (do nothing) or nodal (interpol)
! - The `vartype` of val can be constant, space, time, spacetime
!
-INTERFACE
+INTERFACE GetInterpolation
MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
TYPE(FEVariable_), INTENT(INOUT) :: interpol
TYPE(FEVariable_), INTENT(IN) :: val
END SUBROUTINE master_getInterpolation_2
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE master_getInterpolation_2
-END INTERFACE getInterpolation
+END INTERFACE GetInterpolation
!----------------------------------------------------------------------------
! Interpolation@InterpolMethods
@@ -537,16 +715,12 @@ END SUBROUTINE master_getInterpolation_2
! date: 4 March 2021
! summary: This function returns the interpolation of a scalar
-INTERFACE
+INTERFACE Interpolation
MODULE PURE FUNCTION scalar_interpolation_1(obj, val) RESULT(interpol)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), INTENT(IN) :: val(:)
REAL(DFP), ALLOCATABLE :: interpol(:)
END FUNCTION scalar_interpolation_1
-END INTERFACE
-
-INTERFACE Interpolation
- MODULE PROCEDURE scalar_interpolation_1
END INTERFACE Interpolation
!----------------------------------------------------------------------------
@@ -692,4 +866,4 @@ END FUNCTION matrix_stinterpolation_1
MODULE PROCEDURE matrix_stinterpolation_1
END INTERFACE STInterpolation
-end module ElemshapeData_InterpolMethods
+END MODULE ElemshapeData_InterpolMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90
new file mode 100644
index 000000000..9e35d13e3
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90
@@ -0,0 +1,144 @@
+! 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 ElemshapeData_Lagrange
+USE BaseType, ONLY: ElemshapeData_, &
+ QuadraturePoint_, &
+ ReferenceElement_, &
+ H1_, &
+ LagrangeInterpolation_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: LagrangeElemShapeData
+PUBLIC :: Initiate
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE LagrangeElemShapeData
+ MODULE SUBROUTINE LagrangeElemShapeData1(obj, quad, nsd, xidim, &
+ elemType, refelemCoord, domainName, order, ipType, basisType, &
+ coeff, firstCall, alpha, beta, lambda)
+ CLASS(ElemshapeData_), INTENT(INOUT) :: obj
+ !! element shape data
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ !! quadrature point
+ INTEGER(I4B), INTENT(IN) :: nsd
+ !! number of spatial dimension
+ INTEGER(I4B), INTENT(IN) :: xidim
+ !! dimension of xi
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: refelemCoord(:, :)
+ !! coordinate of reference element
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! name of reference element domain
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of interpolation
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType
+ !! Interpolation point type
+ !! Default value is Equidistance
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Basis function types
+ !! Default value is Monomial
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is false, then coeff will be used
+ !! Default value of firstCall is True
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ !! Jacobi parameter and Ultra-spherical parameter
+ END SUBROUTINE LagrangeElemShapeData1
+END INTERFACE LagrangeElemShapeData
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE LagrangeElemShapeData
+ MODULE SUBROUTINE LagrangeElemShapeData2(obj, quad, refelem, order, &
+ ipType, basisType, coeff, firstCall, alpha, beta, lambda)
+ CLASS(ElemshapeData_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ CLASS(ReferenceElement_), INTENT(IN) :: refelem
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of interpolation
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType
+ !! Interpolation point type
+ !! Default value is Equidistance
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Basis function types
+ !! Default value is Monomial
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE LagrangeElemShapeData2
+END INTERFACE LagrangeElemShapeData
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeElemShapeData
+MODULE SUBROUTINE LagrangeElemShapeData3(obj, quad, refelem, baseContinuity, &
+ baseInterpolation, order, ipType, basisType, coeff, firstCall, &
+ alpha, beta, lambda)
+ CLASS(ElemshapeData_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ CLASS(ReferenceElement_), INTENT(IN) :: refelem
+ TYPE(H1_), INTENT(IN) :: baseContinuity
+ TYPE(LagrangeInterpolation_), INTENT(IN) :: baseInterpolation
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: ipType
+ !! Interpolation point type
+ !! Default value is Equidistance
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Basis function types
+ !! Default value is Monomial
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE LagrangeElemShapeData3
+END INTERFACE LagrangeElemShapeData
+
+INTERFACE Initiate
+ MODULE PROCEDURE LagrangeElemShapeData3
+END INTERFACE Initiate
+
+END MODULE ElemshapeData_Lagrange
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90
index 1df4c3ff0..841d55eda 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90
@@ -16,13 +16,19 @@
MODULE ElemshapeData_Method
USE ElemshapeData_ConstructorMethods
-USE ElemshapeData_DGMethods
USE ElemshapeData_DivergenceMethods
USE ElemshapeData_GetMethods
USE ElemshapeData_GradientMethods
-USE ElemshapeData_H1Methods
-USE ElemshapeData_HCurlMethods
-USE ElemshapeData_HDivMethods
+
+! USE ElemshapeData_H1Methods
+! USE ElemshapeData_HCurlMethods
+! USE ElemshapeData_HDivMethods
+! USE ElemshapeData_DGMethods
+
+USE ElemshapeData_Lagrange
+USE ElemshapeData_Hierarchical
+USE ElemshapeData_Orthogonal
+
USE ElemshapeData_HRGNParamMethods
USE ElemshapeData_HRQIParamMethods
USE ElemshapeData_HminHmaxMethods
@@ -34,4 +40,5 @@ MODULE ElemshapeData_Method
USE ElemshapeData_SetMethods
USE ElemshapeData_StabilizationParamMethods
USE ElemshapeData_UnitNormalMethods
+
END MODULE ElemshapeData_Method
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90
new file mode 100644
index 000000000..0cd4cf1ab
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Orthogonal.F90
@@ -0,0 +1,122 @@
+! 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 ElemshapeData_Orthogonal
+
+USE BaseType, ONLY: ElemshapeData_, &
+ QuadraturePoint_, &
+ ReferenceElement_, &
+ OrthogonalInterpolation_, &
+ H1_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: OrthogonalElemShapeData
+PUBLIC :: Initiate
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate orthogonal shape function data
+
+INTERFACE OrthogonalElemShapeData
+ MODULE SUBROUTINE OrthogonalElemShapeData1(obj, quad, nsd, xidim, &
+ elemType, refelemCoord, domainName, order, basisType, &
+ alpha, beta, lambda)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj
+ !! element shape data
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ !! quadrature point
+ INTEGER(I4B), INTENT(IN) :: nsd
+ !! number of spatial dimension
+ INTEGER(I4B), INTENT(IN) :: xidim
+ !! dimension of xi
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: refelemCoord(:, :)
+ !! coordinate of reference element
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! name of reference element domain
+ INTEGER(I4B), INTENT(IN) :: order
+ !! cell order, always needed
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ !! parameters for Jacobi and Ultraspherical poly
+ END SUBROUTINE OrthogonalElemShapeData1
+END INTERFACE OrthogonalElemShapeData
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE OrthogonalElemShapeData
+ MODULE SUBROUTINE OrthogonalElemShapeData2(obj, quad, refelem, order, &
+ basisType, alpha, beta, lambda)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj
+ !! element shape data
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ !! quadrature points
+ CLASS(ReferenceElement_), INTENT(IN) :: refelem
+ !! reference element
+ INTEGER(I4B), INTENT(IN) :: order
+ !! cell order, always needed
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ !! needed for line, quad, and hexa element
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE OrthogonalElemShapeData2
+END INTERFACE OrthogonalElemShapeData
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE OrthogonalElemShapeData
+ MODULE SUBROUTINE OrthogonalElemShapeData3(obj, quad, refelem, &
+ baseContinuity, baseInterpolation, order, basisType, alpha, beta, lambda)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ CLASS(ReferenceElement_), INTENT(IN) :: refelem
+ !! reference element
+ TYPE(H1_), INTENT(IN) :: baseContinuity
+ !! base continuity
+ TYPE(OrthogonalInterpolation_), INTENT(IN) :: baseInterpolation
+ !! base interpolation
+ INTEGER(I4B), INTENT(IN) :: order
+ !! cell order, always needed
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE OrthogonalElemShapeData3
+END INTERFACE OrthogonalElemShapeData
+
+INTERFACE Initiate
+ MODULE PROCEDURE OrthogonalElemShapeData3
+END INTERFACE Initiate
+
+END MODULE ElemshapeData_Orthogonal
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90
index 4d78a673c..0f71ae33b 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90
@@ -15,14 +15,17 @@
! along with this program. If not, see
!
-module ElemshapeData_ProjectionMethods
+MODULE ElemshapeData_ProjectionMethods
USE BaseType
USE GlobalData
IMPLICIT NONE
PRIVATE
PUBLIC :: getProjectionOfdNdXt
+PUBLIC :: getProjectionOfdNdXt_
PUBLIC :: getProjectionOfdNTdXt
+! TODO: implement
+! PUBLIC :: getProjectionOfdNTdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNdXt@ProjectionMethods
@@ -40,7 +43,7 @@ module ElemshapeData_ProjectionMethods
!
! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$
-INTERFACE
+INTERFACE GetProjectionOfdNdXt
MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :)
@@ -48,11 +51,24 @@ MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val)
REAL(DFP), INTENT(IN) :: val(:)
!! constant value of vector
END SUBROUTINE getProjectionOfdNdXt_1
-END INTERFACE
+END INTERFACE GetProjectionOfdNdXt
-INTERFACE getProjectionOfdNdXt
- MODULE PROCEDURE getProjectionOfdNdXt_1
-END INTERFACE getProjectionOfdNdXt
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetProjectionOfdNdXt_
+ MODULE PURE SUBROUTINE getProjectionOfdNdXt1_(obj, cdNdXt, val, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :)
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE getProjectionOfdNdXt1_
+END INTERFACE GetProjectionOfdNdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNdXt@getMethod
@@ -70,7 +86,7 @@ END SUBROUTINE getProjectionOfdNdXt_1
!
! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$
-INTERFACE
+INTERFACE GetProjectionOfdNdXt
MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
!! ElemshapeData object
@@ -79,11 +95,20 @@ MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val)
CLASS(FEVariable_), INTENT(IN) :: val
!! FEVariable vector
END SUBROUTINE getProjectionOfdNdXt_2
-END INTERFACE
+END INTERFACE GetProjectionOfdNdXt
-INTERFACE getProjectionOfdNdXt
- MODULE PROCEDURE getProjectionOfdNdXt_2
-END INTERFACE getProjectionOfdNdXt
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE GetProjectionOfdNdXt_
+ MODULE PURE SUBROUTINE getProjectionOfdNdXt2_(obj, cdNdXt, val, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :)
+ CLASS(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE getProjectionOfdNdXt2_
+END INTERFACE GetProjectionOfdNdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNdXt@getMethod
@@ -101,7 +126,7 @@ END SUBROUTINE getProjectionOfdNdXt_2
!
! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$
-INTERFACE
+INTERFACE GetProjectionOfdNdXt
MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
!! ElemshapeData object
@@ -110,11 +135,24 @@ MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val)
REAL(DFP), INTENT(IN) :: val(:, :)
!! a vector, defined over quadrature points
END SUBROUTINE getProjectionOfdNdXt_3
-END INTERFACE
+END INTERFACE GetProjectionOfdNdXt
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-INTERFACE getProjectionOfdNdXt
- MODULE PROCEDURE getProjectionOfdNdXt_3
-END INTERFACE getProjectionOfdNdXt
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetProjectionOfdNdXt_
+ MODULE PURE SUBROUTINE getProjectionOfdNdXt3_(obj, cdNdXt, val, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: cdNdXt(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE getProjectionOfdNdXt3_
+END INTERFACE GetProjectionOfdNdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNTdXt@getMethod
@@ -130,7 +168,7 @@ END SUBROUTINE getProjectionOfdNdXt_3
!
! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
-INTERFACE
+INTERFACE GetProjectionOfdNTdXt
MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :)
@@ -138,11 +176,7 @@ MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val)
REAL(DFP), INTENT(IN) :: val(:)
!! constant value of vector
END SUBROUTINE getProjectionOfdNTdXt_1
-END INTERFACE
-
-INTERFACE getProjectionOfdNTdXt
- MODULE PROCEDURE getProjectionOfdNTdXt_1
-END INTERFACE getProjectionOfdNTdXt
+END INTERFACE GetProjectionOfdNTdXt
!----------------------------------------------------------------------------
! getProjectionOfdNTdXt@getMethod
@@ -164,7 +198,7 @@ END SUBROUTINE getProjectionOfdNTdXt_1
!
! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
!
-INTERFACE
+INTERFACE GetProjectionOfdNTdXt
MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :)
@@ -172,11 +206,7 @@ MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val)
TYPE(FEVariable_), INTENT(IN) :: val
!! constant value of vector
END SUBROUTINE getProjectionOfdNTdXt_2
-END INTERFACE
-
-INTERFACE getProjectionOfdNTdXt
- MODULE PROCEDURE getProjectionOfdNTdXt_2
-END INTERFACE getProjectionOfdNTdXt
+END INTERFACE GetProjectionOfdNTdXt
!----------------------------------------------------------------------------
! getProjectionOfdNTdXt@getMethod
@@ -199,16 +229,12 @@ END SUBROUTINE getProjectionOfdNTdXt_2
!
! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
!
-INTERFACE
+INTERFACE GetProjectionOfdNTdXt
MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :, :)
TYPE(FEVariable_), INTENT(IN) :: val
END SUBROUTINE getProjectionOfdNTdXt_3
-END INTERFACE
-
-INTERFACE getProjectionOfdNTdXt
- MODULE PROCEDURE getProjectionOfdNTdXt_3
-END INTERFACE getProjectionOfdNTdXt
+END INTERFACE GetProjectionOfdNTdXt
-end module ElemshapeData_ProjectionMethods
+END MODULE ElemshapeData_ProjectionMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90
index 74069ca7f..77772c3b7 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90
@@ -15,9 +15,11 @@
! along with this program. If not, see
MODULE ElemshapeData_SetMethods
-USE BaSetype
-USE GlobalData
+USE BaseType, ONLY: ElemshapeData_, STElemshapeData_, ElemshapeDataPointer_
+USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: Set
@@ -66,6 +68,8 @@ MODULE PURE SUBROUTINE elemsd_SetThickness(obj, val, N)
!! Nodal values of thickness
REAL(DFP), INTENT(IN) :: N(:, :)
!! Shape function values at quadrature points
+ !! number of rows in n should be same as size of val
+ !! number of columns in N should be equal to nips in obj
END SUBROUTINE elemsd_SetThickness
END INTERFACE SetThickness
@@ -89,6 +93,10 @@ MODULE PURE SUBROUTINE stsd_SetThickness(obj, val, N, T)
CLASS(STElemshapeData_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: val(:, :)
!! Space-time nodal values of thickness
+ !! rows represent space
+ !! columns represets time value
+ !! colsize should be same as size of T
+ !! row size should be same as the number of rows in N
REAL(DFP), INTENT(IN) :: N(:, :)
!! Shape function at spatial quadrature
REAL(DFP), INTENT(IN) :: T(:)
@@ -116,8 +124,12 @@ MODULE PURE SUBROUTINE elemsd_SetBarycentricCoord(obj, val, N)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: val(:, :)
!! Nodal coordinates in `xiJ` format
+ !! colsize of N should be nns
+ !! row size should be same as nsd
REAL(DFP), INTENT(IN) :: N(:, :)
!! When element is not an isoparametric we can supply N.
+ !! row size should be nns
+ !! col size should be nips
END SUBROUTINE elemsd_SetBarycentricCoord
END INTERFACE SetBarycentricCoord
@@ -141,6 +153,7 @@ MODULE PURE SUBROUTINE stsd_SetBarycentricCoord(obj, val, N, T)
CLASS(STElemshapeData_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! space-time Nodal coordinates in `xiJ` format
+ !!
REAL(DFP), INTENT(IN) :: N(:, :), T(:)
!! N and T are required to handle non isoparametric elements
END SUBROUTINE stsd_SetBarycentricCoord
@@ -199,7 +212,12 @@ MODULE PURE SUBROUTINE elemsd_SetJacobian(obj, val, dNdXi)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: val(:, :)
!! nodal coordinates in `xiJ` format
+ !! rowsize is equal to nsd
+ !! colsize equal to nns
REAL(DFP), INTENT(IN) :: dNdXi(:, :, :)
+ !! dim1 is equal to nns
+ !! dim2 is equal to xidim
+ !! dim3 is equal to nips
END SUBROUTINE elemsd_SetJacobian
END INTERFACE SetJacobian
@@ -256,6 +274,9 @@ MODULE PURE SUBROUTINE stsd_SetdNTdt(obj, val)
CLASS(STElemshapeData_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! Space-time nodal values
+ !! dim1 = nsd
+ !! dim2 = nns
+ !! dim3 = nnt
END SUBROUTINE stsd_SetdNTdt
END INTERFACE SetdNTdt
@@ -310,7 +331,7 @@ END SUBROUTINE stsd_SetdNTdXt
! coordinates of spatial nodes at some time in [tn, tn+1]
!@endnote
!
-! The number of cols in val should be same as the number of rows
+! The number of cols in val should be same as the number of rows
! in N and size of first index of dNdXi.
INTERFACE Set
@@ -365,7 +386,7 @@ END SUBROUTINE elemsd_Set1
INTERFACE Set
MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, &
- & celldNdXi, facetN, facetdNdXi)
+ celldNdXi, facetN, facetdNdXi, facetNptrs)
CLASS(ElemshapeData_), INTENT(INOUT) :: facetobj
CLASS(ElemshapeData_), INTENT(INOUT) :: cellobj
REAL(DFP), INTENT(IN) :: cellval(:, :)
@@ -377,6 +398,7 @@ MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, &
REAL(DFP), INTENT(IN) :: celldNdXi(:, :, :)
REAL(DFP), INTENT(IN) :: facetdNdXi(:, :, :)
!! Local derivative of shape functions for geometry
+ INTEGER(I4B), INTENT(IN) :: facetNptrs(:)
END SUBROUTINE elemsd_Set2
END INTERFACE Set
@@ -401,13 +423,15 @@ MODULE PURE SUBROUTINE elemsd_Set3( &
& masterCelldNdXi, &
& masterFacetN, &
& masterFacetdNdXi, &
+ & masterFacetNptrs, &
& slaveFacetobj, &
& slaveCellobj, &
& slaveCellval, &
& slaveCellN, &
& slaveCelldNdXi, &
& slaveFacetN, &
- & slaveFacetdNdXi)
+ & slaveFacetdNdXi, &
+ & slaveFacetNptrs)
CLASS(ElemshapeData_), INTENT(INOUT) :: masterFacetobj
CLASS(ElemshapeData_), INTENT(INOUT) :: masterCellobj
REAL(DFP), INTENT(IN) :: masterCellval(:, :)
@@ -421,6 +445,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( &
REAL(DFP), INTENT(IN) :: masterFacetdNdXi(:, :, :)
!! Local gradient of shape functions for geometry of
!! facet element of master cell
+ INTEGER(I4B), INTENT(IN) :: masterFacetNptrs(:)
+ !!
CLASS(ElemshapeData_), INTENT(INOUT) :: slaveFacetobj
!! Shape function data for facet element of slave cell
CLASS(ElemshapeData_), INTENT(INOUT) :: slaveCellobj
@@ -437,6 +463,7 @@ MODULE PURE SUBROUTINE elemsd_Set3( &
REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :)
!! Local derivative of shape function for geometry of facet element
!! of slave
+ INTEGER(I4B), INTENT(IN) :: slaveFacetNptrs(:)
END SUBROUTINE elemsd_Set3
END INTERFACE Set
diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90
index 385355136..09242bda0 100644
--- a/src/modules/FACE/src/face.F90
+++ b/src/modules/FACE/src/face.F90
@@ -1,287 +1,287 @@
!< FACE, Fortran Ansi Colors Environment.
-module face
+MODULE face
!< FACE, Fortran Ansi Colors Environment.
-use, intrinsic :: iso_fortran_env, only: int32
+USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INT32
-implicit none
-private
-public :: colorize
-public :: colors_samples
-public :: styles_samples
-public :: ASCII
-public :: UCS4
+IMPLICIT NONE
+PRIVATE
+PUBLIC :: colorize
+PUBLIC :: colors_samples
+PUBLIC :: styles_samples
+PUBLIC :: ASCII
+PUBLIC :: UCS4
-interface colorize
+INTERFACE colorize
#if defined ASCII_SUPPORTED && defined ASCII_NEQ_DEFAULT
- module procedure colorize_ascii
- module procedure colorize_default
+ MODULE PROCEDURE colorize_ascii
+ MODULE PROCEDURE colorize_default
#else
- module procedure colorize_default
+ MODULE PROCEDURE colorize_default
#endif
#ifdef UCS4_SUPPORTED
- module procedure colorize_ucs4
+ MODULE PROCEDURE colorize_ucs4
#endif
-endinterface
+end interface
! kind parameters
#ifdef ASCII_SUPPORTED
-integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind.
+INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('ascii') !< ASCII character set kind.
#else
-integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind.
+INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('default') !< ASCII character set kind.
#endif
#ifdef UCS4_SUPPORTED
-integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind.
+INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('iso_10646') !< Unicode character set kind.
#else
-integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind.
+INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('default') !< Unicode character set kind.
#endif
! parameters
-character(26), parameter :: UPPER_ALPHABET='ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet.
-character(26), parameter :: LOWER_ALPHABET='abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet.
-character(1), parameter :: NL=new_line('a') !< New line character.
-character(1), parameter :: ESCAPE=achar(27) !< "\" character.
+CHARACTER(26), PARAMETER :: UPPER_ALPHABET = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' !< Upper case alphabet.
+CHARACTER(26), PARAMETER :: LOWER_ALPHABET = 'abcdefghijklmnopqrstuvwxyz' !< Lower case alphabet.
+CHARACTER(1), PARAMETER :: NL = NEW_LINE('a') !< New line character.
+CHARACTER(1), PARAMETER :: ESCAPE = ACHAR(27) !< "\" character.
! codes
-character(2), parameter :: CODE_START=ESCAPE//'[' !< Start ansi code, "\[".
-character(1), parameter :: CODE_END='m' !< End ansi code, "m".
-character(4), parameter :: CODE_CLEAR=CODE_START//'0'//CODE_END !< Clear all styles, "\[0m".
+CHARACTER(2), PARAMETER :: CODE_START = ESCAPE//'[' !< Start ansi code, "\[".
+CHARACTER(1), PARAMETER :: CODE_END = 'm' !< End ansi code, "m".
+CHARACTER(4), PARAMETER :: CODE_CLEAR = CODE_START//'0'//CODE_END !< Clear all styles, "\[0m".
! styles codes
-character(17), parameter :: STYLES(1:2,1:16)=reshape([&
- 'BOLD_ON ','1 ', & ! Bold on.
- 'ITALICS_ON ','3 ', & ! Italics on.
- 'UNDERLINE_ON ','4 ', & ! Underline on.
- 'INVERSE_ON ','7 ', & ! Inverse on: reverse foreground and background colors.
- 'STRIKETHROUGH_ON ','9 ', & ! Strikethrough on.
- 'BOLD_OFF ','22 ', & ! Bold off.
- 'ITALICS_OFF ','23 ', & ! Italics off.
- 'UNDERLINE_OFF ','24 ', & ! Underline off.
- 'INVERSE_OFF ','27 ', & ! Inverse off: reverse foreground and background colors.
- 'STRIKETHROUGH_OFF','29 ', & ! Strikethrough off.
- 'FRAMED_ON ','51 ', & ! Framed on.
- 'ENCIRCLED_ON ','52 ', & ! Encircled on.
- 'OVERLINED_ON ','53 ', & ! Overlined on.
- 'FRAMED_OFF ','54 ', & ! Framed off.
- 'ENCIRCLED_OFF ','54 ', & ! Encircled off.
- 'OVERLINED_OFF ','55 ' & ! Overlined off.
- ], [2,16]) !< Styles.
+CHARACTER(17), PARAMETER :: STYLES(1:2, 1:16) = RESHAPE([ &
+ 'BOLD_ON ', '1 ', & ! Bold on.
+ 'ITALICS_ON ', '3 ', & ! Italics on.
+ 'UNDERLINE_ON ', '4 ', & ! Underline on.
+'INVERSE_ON ', '7 ', & ! Inverse on: reverse foreground and background colors.
+ 'STRIKETHROUGH_ON ', '9 ', & ! Strikethrough on.
+ 'BOLD_OFF ', '22 ', & ! Bold off.
+ 'ITALICS_OFF ', '23 ', & ! Italics off.
+ 'UNDERLINE_OFF ', '24 ', & ! Underline off.
+'INVERSE_OFF ', '27 ', & ! Inverse off: reverse foreground and background colors.
+ 'STRIKETHROUGH_OFF', '29 ', & ! Strikethrough off.
+ 'FRAMED_ON ', '51 ', & ! Framed on.
+ 'ENCIRCLED_ON ', '52 ', & ! Encircled on.
+ 'OVERLINED_ON ', '53 ', & ! Overlined on.
+ 'FRAMED_OFF ', '54 ', & ! Framed off.
+ 'ENCIRCLED_OFF ', '54 ', & ! Encircled off.
+ 'OVERLINED_OFF ', '55 ' & ! Overlined off.
+ ], [2, 16]) !< Styles.
! colors codes
-character(15), parameter :: COLORS_FG(1:2,1:17)=reshape([&
- 'BLACK ','30 ', & ! Black.
- 'RED ','31 ', & ! Red.
- 'GREEN ','32 ', & ! Green.
- 'YELLOW ','33 ', & ! Yellow.
- 'BLUE ','34 ', & ! Blue.
- 'MAGENTA ','35 ', & ! Magenta.
- 'CYAN ','36 ', & ! Cyan.
- 'WHITE ','37 ', & ! White.
- 'DEFAULT ','39 ', & ! Default (white).
- 'BLACK_INTENSE ','90 ', & ! Black intense.
- 'RED_INTENSE ','91 ', & ! Red intense.
- 'GREEN_INTENSE ','92 ', & ! Green intense.
- 'YELLOW_INTENSE ','93 ', & ! Yellow intense.
- 'BLUE_INTENSE ','94 ', & ! Blue intense.
- 'MAGENTA_INTENSE','95 ', & ! Magenta intense.
- 'CYAN_INTENSE ','96 ', & ! Cyan intense.
- 'WHITE_INTENSE ','97 ' & ! White intense.
- ], [2,17]) !< Foreground colors.
-character(15), parameter :: COLORS_BG(1:2,1:17)=reshape([&
- 'BLACK ','40 ', & ! Black.
- 'RED ','41 ', & ! Red.
- 'GREEN ','42 ', & ! Green.
- 'YELLOW ','43 ', & ! Yellow.
- 'BLUE ','44 ', & ! Blue.
- 'MAGENTA ','45 ', & ! Magenta.
- 'CYAN ','46 ', & ! Cyan.
- 'WHITE ','47 ', & ! White.
- 'DEFAULT ','49 ', & ! Default (black).
- 'BLACK_INTENSE ','100 ', & ! Black intense.
- 'RED_INTENSE ','101 ', & ! Red intense.
- 'GREEN_INTENSE ','102 ', & ! Green intense.
- 'YELLOW_INTENSE ','103 ', & ! Yellow intense.
- 'BLUE_INTENSE ','104 ', & ! Blue intense.
- 'MAGENTA_INTENSE','105 ', & ! Magenta intense.
- 'CYAN_INTENSE ','106 ', & ! Cyan intense.
- 'WHITE_INTENSE ','107 ' & ! White intense.
- ], [2,17]) !< Background colors.
-contains
- ! public procedures
- subroutine colors_samples()
- !< Print to standard output all colors samples.
- integer(int32) :: c !< Counter.
+CHARACTER(15), PARAMETER :: COLORS_FG(1:2, 1:17) = RESHAPE([ &
+ 'BLACK ', '30 ', & ! Black.
+ 'RED ', '31 ', & ! Red.
+ 'GREEN ', '32 ', & ! Green.
+ 'YELLOW ', '33 ', & ! Yellow.
+ 'BLUE ', '34 ', & ! Blue.
+ 'MAGENTA ', '35 ', & ! Magenta.
+ 'CYAN ', '36 ', & ! Cyan.
+ 'WHITE ', '37 ', & ! White.
+ 'DEFAULT ', '39 ', & ! Default (white).
+ 'BLACK_INTENSE ', '90 ', & ! Black intense.
+ 'RED_INTENSE ', '91 ', & ! Red intense.
+ 'GREEN_INTENSE ', '92 ', & ! Green intense.
+ 'YELLOW_INTENSE ', '93 ', & ! Yellow intense.
+ 'BLUE_INTENSE ', '94 ', & ! Blue intense.
+ 'MAGENTA_INTENSE', '95 ', & ! Magenta intense.
+ 'CYAN_INTENSE ', '96 ', & ! Cyan intense.
+ 'WHITE_INTENSE ', '97 ' & ! White intense.
+ ], [2, 17]) !< Foreground colors.
+CHARACTER(15), PARAMETER :: COLORS_BG(1:2, 1:17) = RESHAPE([ &
+ 'BLACK ', '40 ', & ! Black.
+ 'RED ', '41 ', & ! Red.
+ 'GREEN ', '42 ', & ! Green.
+ 'YELLOW ', '43 ', & ! Yellow.
+ 'BLUE ', '44 ', & ! Blue.
+ 'MAGENTA ', '45 ', & ! Magenta.
+ 'CYAN ', '46 ', & ! Cyan.
+ 'WHITE ', '47 ', & ! White.
+ 'DEFAULT ', '49 ', & ! Default (black).
+ 'BLACK_INTENSE ', '100 ', & ! Black intense.
+ 'RED_INTENSE ', '101 ', & ! Red intense.
+ 'GREEN_INTENSE ', '102 ', & ! Green intense.
+ 'YELLOW_INTENSE ', '103 ', & ! Yellow intense.
+ 'BLUE_INTENSE ', '104 ', & ! Blue intense.
+ 'MAGENTA_INTENSE', '105 ', & ! Magenta intense.
+ 'CYAN_INTENSE ', '106 ', & ! Cyan intense.
+ 'WHITE_INTENSE ', '107 ' & ! White intense.
+ ], [2, 17]) !< Background colors.
+CONTAINS
+! public procedures
+SUBROUTINE colors_samples()
+ !< Print to standard output all colors samples.
+ INTEGER(INT32) :: c !< Counter.
- print '(A)', colorize('Foreground colors samples', color_fg='red_intense')
- do c=1, size(COLORS_FG, dim=2)
+ PRINT '(A)', colorize('Foreground colors samples', color_fg='red_intense')
+ DO c = 1, SIZE(COLORS_FG, dim=2)
print '(A)', ' colorize("'//COLORS_FG(1, c)//'", color_fg="'//COLORS_FG(1, c)//'") => '//&
- colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))//&
+ colorize(COLORS_FG(1, c), color_fg=COLORS_FG(1, c))// &
' code: '//colorize(trim(COLORS_FG(2, c)), color_fg=COLORS_FG(1, c), style='inverse_on')
- enddo
- print '(A)', colorize('Background colors samples', color_fg='red_intense')
- do c=1, size(COLORS_BG, dim=2)
+ END DO
+ PRINT '(A)', colorize('Background colors samples', color_fg='red_intense')
+ DO c = 1, SIZE(COLORS_BG, dim=2)
print '(A)', ' colorize("'//COLORS_BG(1, c)//'", color_bg="'//COLORS_BG(1, c)//'") => '//&
- colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))//&
+ colorize(COLORS_BG(1, c), color_bg=COLORS_BG(1, c))// &
' code: '//colorize(trim(COLORS_BG(2, c)), color_bg=COLORS_BG(1, c), style='inverse_on')
- enddo
- endsubroutine colors_samples
+ END DO
+end subroutine colors_samples
- subroutine styles_samples()
- !< Print to standard output all styles samples.
- integer(int32) :: s !< Counter.
+SUBROUTINE styles_samples()
+ !< Print to standard output all styles samples.
+ INTEGER(INT32) :: s !< Counter.
- print '(A)', colorize('Styles samples', color_fg='red_intense')
- do s=1, size(STYLES, dim=2)
+ PRINT '(A)', colorize('Styles samples', color_fg='red_intense')
+ DO s = 1, SIZE(STYLES, dim=2)
print '(A)', ' colorize("'//STYLES(1, s)//'", style="'//STYLES(1, s)//'") => '//&
- colorize(STYLES(1, s), style=STYLES(1, s))//&
+ colorize(STYLES(1, s), style=STYLES(1, s))// &
' code: '//colorize(trim(STYLES(2, s)), color_fg='magenta', style='inverse_on')
- enddo
- endsubroutine styles_samples
+ END DO
+end subroutine styles_samples
- ! private procedures
+! private procedures
pure function colorize_ascii(string, color_fg, color_bg, style) result(colorized)
- !< Colorize and stylize strings, ASCII kind.
- character(len=*, kind=ASCII), intent(in) :: string !< Input string.
- character(len=*), intent(in), optional :: color_fg !< Foreground color definition.
- character(len=*), intent(in), optional :: color_bg !< Background color definition.
- character(len=*), intent(in), optional :: style !< Style definition.
- character(len=:, kind=ASCII), allocatable :: colorized !< Colorized string.
- character(len=:, kind=ASCII), allocatable :: buffer !< Temporary buffer.
- integer(int32) :: i !< Counter.
+ !< Colorize and stylize strings, ASCII kind.
+ CHARACTER(len=*, kind=ASCII), INTENT(in) :: string !< Input string.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: color_fg !< Foreground color definition.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: color_bg !< Background color definition.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: style !< Style definition.
+ CHARACTER(len=:, kind=ASCII), ALLOCATABLE :: colorized !< Colorized string.
+ CHARACTER(len=:, kind=ASCII), ALLOCATABLE :: buffer !< Temporary buffer.
+ INTEGER(INT32) :: i !< Counter.
- colorized = string
- if (present(color_fg)) then
- i = color_index(upper(color_fg))
- if (i>0) then
- buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END
- colorized = buffer//colorized
- buffer = CODE_CLEAR
- colorized = colorized//buffer
- endif
- endif
- if (present(color_bg)) then
- i = color_index(upper(color_bg))
- if (i>0) then
- buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END
- colorized = buffer//colorized
- buffer = CODE_CLEAR
- colorized = colorized//buffer
- endif
- endif
- if (present(style)) then
- i = style_index(upper(style))
- if (i>0) then
- buffer = CODE_START//trim(STYLES(2, i))//CODE_END
- colorized = buffer//colorized
- buffer = CODE_CLEAR
- colorized = colorized//buffer
- endif
- endif
- endfunction colorize_ascii
+ colorized = string
+ IF (PRESENT(color_fg)) THEN
+ i = color_index(upper(color_fg))
+ IF (i > 0) THEN
+ buffer = CODE_START//TRIM(COLORS_FG(2, i))//CODE_END
+ colorized = buffer//colorized
+ buffer = CODE_CLEAR
+ colorized = colorized//buffer
+ END IF
+ END IF
+ IF (PRESENT(color_bg)) THEN
+ i = color_index(upper(color_bg))
+ IF (i > 0) THEN
+ buffer = CODE_START//TRIM(COLORS_BG(2, i))//CODE_END
+ colorized = buffer//colorized
+ buffer = CODE_CLEAR
+ colorized = colorized//buffer
+ END IF
+ END IF
+ IF (PRESENT(style)) THEN
+ i = style_index(upper(style))
+ IF (i > 0) THEN
+ buffer = CODE_START//TRIM(STYLES(2, i))//CODE_END
+ colorized = buffer//colorized
+ buffer = CODE_CLEAR
+ colorized = colorized//buffer
+ END IF
+ END IF
+end function colorize_ascii
pure function colorize_default(string, color_fg, color_bg, style) result(colorized)
- !< Colorize and stylize strings, DEFAULT kind.
- character(len=*), intent(in) :: string !< Input string.
- character(len=*), intent(in), optional :: color_fg !< Foreground color definition.
- character(len=*), intent(in), optional :: color_bg !< Background color definition.
- character(len=*), intent(in), optional :: style !< Style definition.
- character(len=:), allocatable :: colorized !< Colorized string.
- integer(int32) :: i !< Counter.
+ !< Colorize and stylize strings, DEFAULT kind.
+ CHARACTER(len=*), INTENT(in) :: string !< Input string.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: color_fg !< Foreground color definition.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: color_bg !< Background color definition.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: style !< Style definition.
+ CHARACTER(len=:), ALLOCATABLE :: colorized !< Colorized string.
+ INTEGER(INT32) :: i !< Counter.
- colorized = string
- if (present(color_fg)) then
- i = color_index(upper(color_fg))
+ colorized = string
+ IF (PRESENT(color_fg)) THEN
+ i = color_index(upper(color_fg))
if (i>0) colorized = CODE_START//trim(COLORS_FG(2, i))//CODE_END//colorized//CODE_CLEAR
- endif
- if (present(color_bg)) then
- i = color_index(upper(color_bg))
+ END IF
+ IF (PRESENT(color_bg)) THEN
+ i = color_index(upper(color_bg))
if (i>0) colorized = CODE_START//trim(COLORS_BG(2, i))//CODE_END//colorized//CODE_CLEAR
- endif
- if (present(style)) then
- i = style_index(upper(style))
+ END IF
+ IF (PRESENT(style)) THEN
+ i = style_index(upper(style))
if (i>0) colorized = CODE_START//trim(STYLES(2, i))//CODE_END//colorized//CODE_CLEAR
- endif
- endfunction colorize_default
+ END IF
+end function colorize_default
pure function colorize_ucs4(string, color_fg, color_bg, style) result(colorized)
- !< Colorize and stylize strings, UCS4 kind.
- character(len=*, kind=UCS4), intent(in) :: string !< Input string.
- character(len=*), intent(in), optional :: color_fg !< Foreground color definition.
- character(len=*), intent(in), optional :: color_bg !< Background color definition.
- character(len=*), intent(in), optional :: style !< Style definition.
- character(len=:, kind=UCS4), allocatable :: colorized !< Colorized string.
- character(len=:, kind=UCS4), allocatable :: buffer !< Temporary buffer.
- integer(int32) :: i !< Counter.
+ !< Colorize and stylize strings, UCS4 kind.
+ CHARACTER(len=*, kind=UCS4), INTENT(in) :: string !< Input string.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: color_fg !< Foreground color definition.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: color_bg !< Background color definition.
+ CHARACTER(len=*), INTENT(in), OPTIONAL :: style !< Style definition.
+ CHARACTER(len=:, kind=UCS4), ALLOCATABLE :: colorized !< Colorized string.
+ CHARACTER(len=:, kind=UCS4), ALLOCATABLE :: buffer !< Temporary buffer.
+ INTEGER(INT32) :: i !< Counter.
- colorized = string
- if (present(color_fg)) then
- i = color_index(upper(color_fg))
- if (i>0) then
- buffer = CODE_START//trim(COLORS_FG(2, i))//CODE_END
- colorized = buffer//colorized
- buffer = CODE_CLEAR
- colorized = colorized//buffer
- endif
- endif
- if (present(color_bg)) then
- i = color_index(upper(color_bg))
- if (i>0) then
- buffer = CODE_START//trim(COLORS_BG(2, i))//CODE_END
- colorized = buffer//colorized
- buffer = CODE_CLEAR
- colorized = colorized//buffer
- endif
- endif
- if (present(style)) then
- i = style_index(upper(style))
- if (i>0) then
- buffer = CODE_START//trim(STYLES(2, i))//CODE_END
- colorized = buffer//colorized
- buffer = CODE_CLEAR
- colorized = colorized//buffer
- endif
- endif
- endfunction colorize_ucs4
+ colorized = string
+ IF (PRESENT(color_fg)) THEN
+ i = color_index(upper(color_fg))
+ IF (i > 0) THEN
+ buffer = CODE_START//TRIM(COLORS_FG(2, i))//CODE_END
+ colorized = buffer//colorized
+ buffer = CODE_CLEAR
+ colorized = colorized//buffer
+ END IF
+ END IF
+ IF (PRESENT(color_bg)) THEN
+ i = color_index(upper(color_bg))
+ IF (i > 0) THEN
+ buffer = CODE_START//TRIM(COLORS_BG(2, i))//CODE_END
+ colorized = buffer//colorized
+ buffer = CODE_CLEAR
+ colorized = colorized//buffer
+ END IF
+ END IF
+ IF (PRESENT(style)) THEN
+ i = style_index(upper(style))
+ IF (i > 0) THEN
+ buffer = CODE_START//TRIM(STYLES(2, i))//CODE_END
+ colorized = buffer//colorized
+ buffer = CODE_CLEAR
+ colorized = colorized//buffer
+ END IF
+ END IF
+end function colorize_ucs4
- elemental function color_index(color)
- !< Return the array-index corresponding to the queried color.
- !<
- !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index.
- !< Thus, the foreground array is used.
- character(len=*), intent(in) :: color !< Color definition.
- integer(int32) :: color_index !< Index into the colors arrays.
- integer(int32) :: c !< Counter.
+ELEMENTAL FUNCTION color_index(color)
+ !< Return the array-index corresponding to the queried color.
+ !<
+ !< @note Because Foreground and backround colors lists share the same name, no matter what array is used to find the color index.
+ !< Thus, the foreground array is used.
+ CHARACTER(len=*), INTENT(in) :: color !< Color definition.
+ INTEGER(INT32) :: color_index !< Index into the colors arrays.
+ INTEGER(INT32) :: c !< Counter.
- color_index = 0
- do c=1, size(COLORS_FG, dim=2)
- if (trim(COLORS_FG(1, c))==trim(adjustl(color))) then
- color_index = c
- exit
- endif
- enddo
- endfunction color_index
+ color_index = 0
+ DO c = 1, SIZE(COLORS_FG, dim=2)
+ IF (TRIM(COLORS_FG(1, c)) == TRIM(ADJUSTL(color))) THEN
+ color_index = c
+ EXIT
+ END IF
+ END DO
+end function color_index
- elemental function style_index(style)
- !< Return the array-index corresponding to the queried style.
- character(len=*), intent(in) :: style !< Style definition.
- integer(int32) :: style_index !< Index into the styles array.
- integer(int32) :: s !< Counter.
+ELEMENTAL FUNCTION style_index(style)
+ !< Return the array-index corresponding to the queried style.
+ CHARACTER(len=*), INTENT(in) :: style !< Style definition.
+ INTEGER(INT32) :: style_index !< Index into the styles array.
+ INTEGER(INT32) :: s !< Counter.
- style_index = 0
- do s=1, size(STYLES, dim=2)
- if (trim(STYLES(1, s))==trim(adjustl(style))) then
- style_index = s
- exit
- endif
- enddo
- endfunction style_index
+ style_index = 0
+ DO s = 1, SIZE(STYLES, dim=2)
+ IF (TRIM(STYLES(1, s)) == TRIM(ADJUSTL(style))) THEN
+ style_index = s
+ EXIT
+ END IF
+ END DO
+end function style_index
- elemental function upper(string)
- !< Return a string with all uppercase characters.
- character(len=*), intent(in) :: string !< Input string.
- character(len=len(string)) :: upper !< Upper case string.
- integer :: n1 !< Characters counter.
- integer :: n2 !< Characters counter.
+ELEMENTAL FUNCTION upper(string)
+ !< Return a string with all uppercase characters.
+ CHARACTER(len=*), INTENT(in) :: string !< Input string.
+ CHARACTER(len=LEN(string)) :: upper !< Upper case string.
+ INTEGER :: n1 !< Characters counter.
+ INTEGER :: n2 !< Characters counter.
- upper = string
- do n1=1, len(string)
- n2 = index(LOWER_ALPHABET, string(n1:n1))
- if (n2>0) upper(n1:n1) = UPPER_ALPHABET(n2:n2)
- enddo
- endfunction upper
+ upper = string
+ DO n1 = 1, LEN(string)
+ n2 = INDEX(LOWER_ALPHABET, string(n1:n1))
+ IF (n2 > 0) upper(n1:n1) = UPPER_ALPHABET(n2:n2)
+ END DO
+end function upper
endmodule face
diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90
index 887b43b2e..718aba242 100644
--- a/src/modules/FEVariable/src/FEVariable_Method.F90
+++ b/src/modules/FEVariable/src/FEVariable_Method.F90
@@ -15,9 +15,19 @@
! along with this program. If not, see
MODULE FEVariable_Method
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: Display
@@ -32,6 +42,7 @@ MODULE FEVariable_Method
PUBLIC :: isNodalVariable
PUBLIC :: isQuadratureVariable
PUBLIC :: Get
+PUBLIC :: Get_
PUBLIC :: OPERATOR(+)
PUBLIC :: OPERATOR(-)
PUBLIC :: OPERATOR(*)
@@ -45,6 +56,10 @@ MODULE FEVariable_Method
PUBLIC :: OPERATOR(.NE.)
PUBLIC :: MEAN
PUBLIC :: GetLambdaFromYoungsModulus
+PUBLIC :: ASSIGNMENT(=)
+
+INTEGER(I4B), PARAMETER :: CAPACITY_EXPAND_FACTOR = 1
+! capacity = tsize * CAPACITY_EXPAND_FACTOR
!----------------------------------------------------------------------------
! GetLambdaFromYoungsModulus@SpecialMethods
@@ -55,8 +70,8 @@ MODULE FEVariable_Method
! summary: Get lame parameter lambda from YoungsModulus
INTERFACE GetLambdaFromYoungsModulus
- MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus(youngsModulus, &
- & shearModulus, lambda)
+ MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus(youngsModulus, &
+ shearModulus, lambda)
TYPE(FEVariable_), INTENT(IN) :: youngsModulus, shearModulus
TYPE(FEVariable_), INTENT(INOUT) :: lambda
END SUBROUTINE fevar_GetLambdaFromYoungsModulus
@@ -71,16 +86,12 @@ END SUBROUTINE fevar_GetLambdaFromYoungsModulus
! update: 2021-12-10
! summary: Displays the content of [[FEVariable_]]
-INTERFACE
+INTERFACE Display
MODULE SUBROUTINE fevar_Display(obj, Msg, UnitNo)
TYPE(FEVariable_), INTENT(IN) :: obj
CHARACTER(*), INTENT(IN) :: Msg
INTEGER(I4B), OPTIONAL, INTENT(IN) :: UnitNo
END SUBROUTINE fevar_Display
-END INTERFACE
-
-INTERFACE Display
- MODULE PROCEDURE fevar_Display
END INTERFACE Display
!----------------------------------------------------------------------------
@@ -92,7 +103,7 @@ END SUBROUTINE fevar_Display
! update: 2021-12-10
! summary: Create quadrature variable, which is Scalar, Constant
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -100,10 +111,6 @@ MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) &
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Scalar_Constant
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_Constant
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -115,7 +122,7 @@ END FUNCTION Quadrature_Scalar_Constant
! update: 2021-12-10
! summary: Create quadrature variable, which is Scalar, Space
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -123,10 +130,6 @@ MODULE PURE FUNCTION Quadrature_Scalar_Space(val, rank, vartype) &
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Scalar_Space
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_Space
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -138,7 +141,7 @@ END FUNCTION Quadrature_Scalar_Space
! update: 2021-12-10
! summary: Create quadrature variable, which is Scalar, Time
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -146,10 +149,6 @@ MODULE PURE FUNCTION Quadrature_Scalar_Time(val, rank, vartype) &
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Scalar_Time
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_Time
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -161,7 +160,7 @@ END FUNCTION Quadrature_Scalar_Time
! update: 2021-12-10
! summary: Create quadrature variable, which is Scalar, SpaceTime
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -169,10 +168,26 @@ MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime(val, rank, vartype) &
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Scalar_SpaceTime
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Scalar, SpaceTime
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_SpaceTime
+ MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Quadrature_Scalar_SpaceTime2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -184,7 +199,7 @@ END FUNCTION Quadrature_Scalar_SpaceTime
! update: 2021-12-10
! summary: Create quadrature variable, which is Vector, Constant
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -192,10 +207,6 @@ MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) &
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Vector_Constant
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_Constant
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -207,7 +218,8 @@ END FUNCTION Quadrature_Vector_Constant
! update: 2021-12-10
! summary: Create quadrature variable, which is Vector, Space
-INTERFACE
+INTERFACE QuadratureVariable
+
MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -215,10 +227,27 @@ MODULE PURE FUNCTION Quadrature_Vector_Space(val, rank, vartype) &
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Vector_Space
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Vector, Space
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_Space
+
+ MODULE PURE FUNCTION Quadrature_Vector_Space2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Quadrature_Vector_Space2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -230,7 +259,7 @@ END FUNCTION Quadrature_Vector_Space
! update: 2021-12-10
! summary: Create quadrature variable, which is Vector, Time
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Vector_Time(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -238,10 +267,26 @@ MODULE PURE FUNCTION Quadrature_Vector_Time(val, rank, vartype) &
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Vector_Time
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Vector, Time
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_Time
+ MODULE PURE FUNCTION Quadrature_Vector_Time2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Quadrature_Vector_Time2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -253,7 +298,7 @@ END FUNCTION Quadrature_Vector_Time
! update: 2021-12-10
! summary: Create quadrature variable, which is Vector, SpaceTime
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -261,10 +306,26 @@ MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) &
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Vector_SpaceTime
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Vector, SpaceTime
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_SpaceTime
+ MODULE PURE FUNCTION Quadrature_Vector_SpaceTime2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(3)
+ END FUNCTION Quadrature_Vector_SpaceTime2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -276,7 +337,7 @@ END FUNCTION Quadrature_Vector_SpaceTime
! update: 2021-12-10
! summary: Create quadrature variable, which is Matrix, Constant
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -284,10 +345,26 @@ MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) &
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Matrix_Constant
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Matrix, Constant
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_Constant
+ MODULE PURE FUNCTION Quadrature_Matrix_Constant2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Quadrature_Matrix_Constant2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -299,7 +376,7 @@ END FUNCTION Quadrature_Matrix_Constant
! update: 2021-12-10
! summary: Create quadrature variable, which is Matrix, Space
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Matrix_Space(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -307,10 +384,26 @@ MODULE PURE FUNCTION Quadrature_Matrix_Space(val, rank, vartype) &
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Matrix_Space
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Matrix, Space
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_Space
+ MODULE PURE FUNCTION Quadrature_Matrix_Space2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(3)
+ END FUNCTION Quadrature_Matrix_Space2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -322,7 +415,7 @@ END FUNCTION Quadrature_Matrix_Space
! update: 2021-12-10
! summary: Create quadrature variable, which is Matrix, Time
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Matrix_Time(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -330,10 +423,26 @@ MODULE PURE FUNCTION Quadrature_Matrix_Time(val, rank, vartype) &
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Matrix_Time
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Matrix, Time
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_Time
+ MODULE PURE FUNCTION Quadrature_Matrix_Time2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(3)
+ END FUNCTION Quadrature_Matrix_Time2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -345,7 +454,7 @@ END FUNCTION Quadrature_Matrix_Time
! update: 2021-12-10
! summary: Create quadrature variable, which is Matrix, SpaceTime
-INTERFACE
+INTERFACE QuadratureVariable
MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -353,10 +462,26 @@ MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) &
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
END FUNCTION Quadrature_Matrix_SpaceTime
-END INTERFACE
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Matrix, SpaceTime
INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_SpaceTime
+ MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(4)
+ END FUNCTION Quadrature_Matrix_SpaceTime2
END INTERFACE QuadratureVariable
!----------------------------------------------------------------------------
@@ -368,14 +493,10 @@ END FUNCTION Quadrature_Matrix_SpaceTime
! update: 2021-12-10
! summary: Deallocates the content of FEVariable
-INTERFACE
+INTERFACE DEALLOCATE
MODULE PURE SUBROUTINE fevar_Deallocate(obj)
TYPE(FEVariable_), INTENT(INOUT) :: obj
END SUBROUTINE fevar_Deallocate
-END INTERFACE
-
-INTERFACE DEALLOCATE
- MODULE PROCEDURE fevar_Deallocate
END INTERFACE DEALLOCATE
!----------------------------------------------------------------------------
@@ -387,7 +508,7 @@ END SUBROUTINE fevar_Deallocate
! update: 2021-12-10
! summary: Create nodal variable, which is scalar, constant
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -395,10 +516,6 @@ MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) &
CLASS(FEVariableScalar_), INTENT(IN) :: rank
CLASS(FEVariableConstant_), INTENT(IN) :: vartype
END FUNCTION Nodal_Scalar_Constant
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Scalar_Constant
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -410,17 +527,14 @@ END FUNCTION Nodal_Scalar_Constant
! update: 2021-12-10
! summary: Create nodal variable, which is scalar, Space
-INTERFACE
+INTERFACE NodalVariable
+
MODULE PURE FUNCTION Nodal_Scalar_Space(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:)
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
END FUNCTION Nodal_Scalar_Space
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Scalar_Space
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -432,17 +546,13 @@ END FUNCTION Nodal_Scalar_Space
! update: 2021-12-10
! summary: Create nodal variable, which is scalar, Time
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Scalar_Time(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:)
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
END FUNCTION Nodal_Scalar_Time
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Scalar_Time
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -454,17 +564,32 @@ END FUNCTION Nodal_Scalar_Time
! update: 2021-12-10
! summary: Create nodal variable, which is scalar, SpaceTime
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Scalar_SpaceTime(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:, :)
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
END FUNCTION Nodal_Scalar_SpaceTime
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is scalar, SpaceTime
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Scalar_SpaceTime
+ MODULE PURE FUNCTION Nodal_Scalar_SpaceTime2(val, rank, vartype, s) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Nodal_Scalar_SpaceTime2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -476,7 +601,7 @@ END FUNCTION Nodal_Scalar_SpaceTime
! update: 2021-12-10
! summary: Create nodal variable, which is vector, Constant
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -484,10 +609,6 @@ MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) &
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
END FUNCTION Nodal_Vector_Constant
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_Constant
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -499,17 +620,32 @@ END FUNCTION Nodal_Vector_Constant
! update: 2021-12-10
! summary: Create nodal variable, which is vector, Space
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Vector_Space(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:, :)
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
END FUNCTION Nodal_Vector_Space
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is vector, Space
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_Space
+ MODULE PURE FUNCTION Nodal_Vector_Space2(val, rank, vartype, s) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Nodal_Vector_Space2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -521,17 +657,32 @@ END FUNCTION Nodal_Vector_Space
! update: 2021-12-10
! summary: Create nodal variable, which is vector, Time
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Vector_Time(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:, :)
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
END FUNCTION Nodal_Vector_Time
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is vector, Time
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_Time
+ MODULE PURE FUNCTION Nodal_Vector_Time2(val, rank, vartype, s) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Nodal_Vector_Time2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -543,7 +694,7 @@ END FUNCTION Nodal_Vector_Time
! update: 2021-12-10
! summary: Create nodal variable, which is vector, SpaceTime
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -551,10 +702,26 @@ MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) &
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
END FUNCTION Nodal_Vector_SpaceTime
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is vector, SpaceTime
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_SpaceTime
+ MODULE PURE FUNCTION Nodal_Vector_SpaceTime2(val, rank, vartype, s) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(3)
+ END FUNCTION Nodal_Vector_SpaceTime2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -566,7 +733,7 @@ END FUNCTION Nodal_Vector_SpaceTime
! update: 2021-12-10
! summary: Create nodal variable, which is Matrix, Constant
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -574,10 +741,26 @@ MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) &
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
END FUNCTION Nodal_Matrix_Constant
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is Matrix, Constant
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_Constant
+ MODULE PURE FUNCTION Nodal_Matrix_Constant2(val, rank, vartype, s) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(2)
+ END FUNCTION Nodal_Matrix_Constant2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -589,17 +772,32 @@ END FUNCTION Nodal_Matrix_Constant
! update: 2021-12-10
! summary: Create nodal variable, which is Matrix, Space
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Matrix_Space(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:, :, :)
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
END FUNCTION Nodal_Matrix_Space
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is Matrix, Space
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_Space
+ MODULE PURE FUNCTION Nodal_Matrix_Space2(val, rank, vartype, s) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(3)
+ END FUNCTION Nodal_Matrix_Space2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -611,17 +809,32 @@ END FUNCTION Nodal_Matrix_Space
! update: 2021-12-10
! summary: Create nodal variable, which is Matrix, Time
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Matrix_Time(val, rank, vartype) RESULT(obj)
TYPE(FEVariable_) :: obj
REAL(DFP), INTENT(IN) :: val(:, :, :)
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
END FUNCTION Nodal_Matrix_Time
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is Matrix, Time
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_Time
+ MODULE PURE FUNCTION Nodal_Matrix_Time2(val, rank, vartype, s) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(3)
+ END FUNCTION Nodal_Matrix_Time2
END INTERFACE NodalVariable
!----------------------------------------------------------------------------
@@ -633,7 +846,7 @@ END FUNCTION Nodal_Matrix_Time
! update: 2021-12-10
! summary: Create nodal variable, which is Matrix, SpaceTime
-INTERFACE
+INTERFACE NodalVariable
MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) &
& RESULT(obj)
TYPE(FEVariable_) :: obj
@@ -641,41 +854,114 @@ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) &
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
END FUNCTION Nodal_Matrix_SpaceTime
-END INTERFACE
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is Matrix, SpaceTime
INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_SpaceTime
+ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime2(val, rank, vartype, s) &
+ & RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: s(4)
+ END FUNCTION Nodal_Matrix_SpaceTime2
END INTERFACE NodalVariable
+!----------------------------------------------------------------------------
+! Assignment@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-13
+! summary: obj1 = obj2
+
+INTERFACE ASSIGNMENT(=)
+ MODULE PURE SUBROUTINE obj_Copy(obj1, obj2)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj1
+ TYPE(FEVariable_), INTENT(IN) :: obj2
+ END SUBROUTINE obj_Copy
+END INTERFACE
+
!----------------------------------------------------------------------------
! SIZE@GetMethods
!----------------------------------------------------------------------------
-INTERFACE
- MODULE PURE FUNCTION fevar_Size(obj, Dim) RESULT(Ans)
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-12
+! summary: Returns the size of variable
+!
+!# Introduction
+!
+! If dim is present then obj%s(dim) is returned.
+!
+! In this case be careful that dim is not out of bound.
+!
+! Scalar, constant => dim <=1
+! Scalar, space or time => dim <=1
+! Scalar, spaceTime => dim <=2
+!
+! Vector, constant => dim <=1
+! Vector, space => dim <=2
+! Vector, time => dim <=2
+! Vector, spaceTime => dim <=3
+!
+! Matrix, constant => dim <=2
+! Matrix, space => dim <=3
+! Matrix, time => dim <=3
+! Matrix, spaceTime => dim <=4
+!
+! If dim is absent then following rule is followed
+!
+! For scalar, ans = 1
+! For vector, ans = obj%s(1)
+! For matrix, and = obj%s(1) * obj%s(2)
+
+INTERFACE Size
+ MODULE PURE FUNCTION fevar_Size(obj, Dim) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
INTEGER(I4B), OPTIONAL, INTENT(IN) :: Dim
- INTEGER(I4B) :: Ans
+ INTEGER(I4B) :: ans
END FUNCTION fevar_Size
-END INTERFACE
-
-INTERFACE SIZE
- MODULE PROCEDURE fevar_Size
-END INTERFACE SIZE
+END INTERFACE Size
!----------------------------------------------------------------------------
! SHAPE@GetMethods
!----------------------------------------------------------------------------
-INTERFACE
- MODULE PURE FUNCTION fevar_Shape(obj) RESULT(Ans)
- CLASS(FEVariable_), INTENT(IN) :: obj
- INTEGER(I4B), ALLOCATABLE :: Ans(:)
- END FUNCTION fevar_Shape
-END INTERFACE
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-12
+! summary: Returns the shape of data
+!
+!# Introduction
+!
+! ans depends on the rank and vartype
+!
+!| rank | vartype | ans |
+!| --- | --- | --- |
+!| Scalar | Constant | [1] |
+!| Scalar | Space, Time | [obj%s(1)] |
+!| Scalar | SpaceTime | [obj%s(1), obj%s(2)] |
+!| Vector | Constant | [obj%s(1)] |
+!| Vector | Space, Time | [obj%s(1), obj%s(2)] |
+!| Vector | SpaceTime | [obj%s(1), obj%s(2), obj%s(3)] |
+!| Matrix | Constant | [obj%s(1), obj%s(2)] |
+!| Matrix | Space, Time | [obj%s(1), obj%s(2), obj%s(3)] |
+!| Matrix | SpaceTime | [obj%s(1), obj%s(2), obj%s(3), obj%s(4)] |
INTERFACE Shape
- MODULE PROCEDURE fevar_Shape
+ MODULE PURE FUNCTION fevar_Shape(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ INTEGER(I4B), ALLOCATABLE :: ans(:)
+ END FUNCTION fevar_Shape
END INTERFACE Shape
!----------------------------------------------------------------------------
@@ -687,17 +973,13 @@ END FUNCTION fevar_Shape
! update: 2021-11-27
! summary: Returns the rank of FEvariable
-INTERFACE
+INTERFACE OPERATOR(.RANK.)
MODULE PURE FUNCTION fevar_rank(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
INTEGER(I4B) :: ans
END FUNCTION fevar_rank
END INTERFACE
-INTERFACE OPERATOR(.RANK.)
- MODULE PROCEDURE fevar_rank
-END INTERFACE OPERATOR(.RANK.)
-
!----------------------------------------------------------------------------
! vartype@GetMethods
!----------------------------------------------------------------------------
@@ -707,17 +989,13 @@ END FUNCTION fevar_rank
! update: 2021-11-27
! summary: Returns the vartype of FEvariable
-INTERFACE
+INTERFACE OPERATOR(.vartype.)
MODULE PURE FUNCTION fevar_vartype(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
INTEGER(I4B) :: ans
END FUNCTION fevar_vartype
END INTERFACE
-INTERFACE OPERATOR(.vartype.)
- MODULE PROCEDURE fevar_vartype
-END INTERFACE OPERATOR(.varType.)
-
!----------------------------------------------------------------------------
! defineon@GetMethods
!----------------------------------------------------------------------------
@@ -727,17 +1005,13 @@ END FUNCTION fevar_vartype
! update: 2021-11-27
! summary: Returns the defineon of FEvariable
-INTERFACE
+INTERFACE OPERATOR(.defineon.)
MODULE PURE FUNCTION fevar_defineon(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
INTEGER(I4B) :: ans
END FUNCTION fevar_defineon
END INTERFACE
-INTERFACE OPERATOR(.defineon.)
- MODULE PROCEDURE fevar_defineon
-END INTERFACE OPERATOR(.defineon.)
-
!----------------------------------------------------------------------------
! isNodalVariable@GetMethods
!----------------------------------------------------------------------------
@@ -747,15 +1021,11 @@ END FUNCTION fevar_defineon
! update: 2021-11-27
! summary: Returns the defineon of FEvariable
-INTERFACE
+INTERFACE isNodalVariable
MODULE PURE FUNCTION fevar_isNodalVariable(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
LOGICAL(LGT) :: ans
END FUNCTION fevar_isNodalVariable
-END INTERFACE
-
-INTERFACE isNodalVariable
- MODULE PROCEDURE fevar_isNodalVariable
END INTERFACE isNodalVariable
!----------------------------------------------------------------------------
@@ -767,15 +1037,11 @@ END FUNCTION fevar_isNodalVariable
! update: 2021-11-27
! summary: Returns the defineon of FEvariable
-INTERFACE
+INTERFACE isQuadratureVariable
MODULE PURE FUNCTION fevar_isQuadratureVariable(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
LOGICAL(LGT) :: ans
END FUNCTION fevar_isQuadratureVariable
-END INTERFACE
-
-INTERFACE isQuadratureVariable
- MODULE PROCEDURE fevar_isQuadratureVariable
END INTERFACE isQuadratureVariable
!----------------------------------------------------------------------------
@@ -786,17 +1052,13 @@ END FUNCTION fevar_isQuadratureVariable
! date: 2 Jan 2022
! summary: Returns value which is scalar, constant
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Scalar_Constant(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
REAL(DFP) :: val
END FUNCTION Scalar_Constant
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Scalar_Constant
END INTERFACE Get
!----------------------------------------------------------------------------
@@ -807,19 +1069,33 @@ END FUNCTION Scalar_Constant
! date: 2 Jan 2022
! summary: Returns value which is scalar, space
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Scalar_Space(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:)
END FUNCTION Scalar_Space
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Scalar_Space
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is scalar, space without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Scalar_Space_(obj, rank, vartype, val, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE Scalar_Space_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -828,19 +1104,33 @@ END FUNCTION Scalar_Space
! date: 2 Jan 2022
! summary: Returns value which is scalar, time
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Scalar_Time(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:)
END FUNCTION Scalar_Time
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Scalar_Time
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is scalar, time without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Scalar_Time_(obj, rank, vartype, val, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE Scalar_Time_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -849,19 +1139,34 @@ END FUNCTION Scalar_Time
! date: 2 Jan 2022
! summary: Returns value which is scalar, SpaceTime
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Scalar_SpaceTime(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableScalar_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :)
END FUNCTION Scalar_SpaceTime
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Scalar_SpaceTime
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is scalar, SpaceTime without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Scalar_SpaceTime_(obj, rank, vartype, val, &
+ nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Scalar_SpaceTime_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -870,19 +1175,33 @@ END FUNCTION Scalar_SpaceTime
! date: 2 Jan 2022
! summary: Returns value which is vector, constant
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Vector_Constant(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:)
END FUNCTION Vector_Constant
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Vector_Constant
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is vector, constant without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Vector_Constant_(obj, rank, vartype, val, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE Vector_Constant_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -891,19 +1210,34 @@ END FUNCTION Vector_Constant
! date: 2 Jan 2022
! summary: Returns value which is vector, space
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Vector_Space(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :)
END FUNCTION Vector_Space
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Vector_Space
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is vector, space without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Vector_Space_(obj, rank, vartype, val, &
+ nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Vector_Space_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -912,19 +1246,34 @@ END FUNCTION Vector_Space
! date: 2 Jan 2022
! summary: Returns value which is vector, time
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Vector_Time(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :)
END FUNCTION Vector_Time
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Vector_Time
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is vector, time without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Vector_Time_(obj, rank, vartype, val, &
+ nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Vector_Time_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -933,19 +1282,34 @@ END FUNCTION Vector_Time
! date: 2 Jan 2022
! summary: Returns value which is vector, spaceTime
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Vector_SpaceTime(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableVector_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :, :)
END FUNCTION Vector_SpaceTime
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Vector_SpaceTime
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is vector, spaceTime without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Vector_SpaceTime_(obj, rank, vartype, val, &
+ dim1, dim2, dim3)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE Vector_SpaceTime_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -954,19 +1318,34 @@ END FUNCTION Vector_SpaceTime
! date: 2 Jan 2022
! summary: Returns value which is Matrix, Constant
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Matrix_Constant(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableConstant_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :)
END FUNCTION Matrix_Constant
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Matrix_Constant
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is Matrix, Constant without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Matrix_Constant_(obj, rank, vartype, val, &
+ nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(inout) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Matrix_Constant_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -975,19 +1354,34 @@ END FUNCTION Matrix_Constant
! date: 2 Jan 2022
! summary: Returns value which is Matrix, Space
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Matrix_Space(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableSpace_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :, :)
END FUNCTION Matrix_Space
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Matrix_Space
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is Matrix, Space without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Matrix_Space_(obj, rank, vartype, val, &
+ dim1, dim2, dim3)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE Matrix_Space_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -996,19 +1390,34 @@ END FUNCTION Matrix_Space
! date: 2 Jan 2022
! summary: Returns value which is Matrix, Time
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Matrix_Time(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableTime_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :, :)
END FUNCTION Matrix_Time
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Matrix_Time
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is Matrix, Time without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Matrix_Time_(obj, rank, vartype, val, &
+ dim1, dim2, dim3)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE Matrix_Time_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Get@GetMethods
!----------------------------------------------------------------------------
@@ -1017,19 +1426,34 @@ END FUNCTION Matrix_Time
! date: 2 Jan 2022
! summary: Returns value which is Matrix, SpaceTime
-INTERFACE
+INTERFACE Get
MODULE PURE FUNCTION Matrix_SpaceTime(obj, rank, vartype) RESULT(val)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableMatrix_), INTENT(IN) :: rank
TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
REAL(DFP), ALLOCATABLE :: val(:, :, :, :)
END FUNCTION Matrix_SpaceTime
-END INTERFACE
-
-INTERFACE Get
- MODULE PROCEDURE Matrix_SpaceTime
END INTERFACE Get
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: Returns value which is Matrix, SpaceTime without allocation
+
+INTERFACE Get_
+ MODULE PURE SUBROUTINE Matrix_SpaceTime_(obj, rank, vartype, val, &
+ dim1, dim2, dim3, dim4)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(INOUT) :: val(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE Matrix_SpaceTime_
+END INTERFACE Get_
+
!----------------------------------------------------------------------------
! Addition@AdditioMethods
!----------------------------------------------------------------------------
@@ -1039,18 +1463,14 @@ END FUNCTION Matrix_SpaceTime
! update: 2021-12-12
! summary: FEVariable = FEVariable + FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Addition1(obj1, obj2) RESULT(Ans)
+INTERFACE OPERATOR(+)
+ MODULE PURE FUNCTION fevar_Addition1(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Addition1
END INTERFACE
-INTERFACE OPERATOR(+)
- MODULE PROCEDURE fevar_Addition1
-END INTERFACE OPERATOR(+)
-
!----------------------------------------------------------------------------
! Addition@AdditioMethods
!----------------------------------------------------------------------------
@@ -1060,18 +1480,15 @@ END FUNCTION fevar_Addition1
! update: 2021-12-12
! summary: FEVariable = FEVariable + Real
-INTERFACE
- MODULE PURE FUNCTION fevar_Addition2(obj1, val) RESULT(Ans)
+INTERFACE OPERATOR(+)
+
+ MODULE PURE FUNCTION fevar_Addition2(obj1, val) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
REAL(DFP), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Addition2
END INTERFACE
-INTERFACE OPERATOR(+)
- MODULE PROCEDURE fevar_Addition2
-END INTERFACE OPERATOR(+)
-
!----------------------------------------------------------------------------
! Addition@AdditioMethods
!----------------------------------------------------------------------------
@@ -1081,18 +1498,14 @@ END FUNCTION fevar_Addition2
! update: 2021-12-12
! summary: FEVariable = Real + FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Addition3(val, obj1) RESULT(Ans)
+INTERFACE OPERATOR(+)
+ MODULE PURE FUNCTION fevar_Addition3(val, obj1) RESULT(ans)
REAL(DFP), INTENT(IN) :: val
CLASS(FEVariable_), INTENT(IN) :: obj1
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Addition3
END INTERFACE
-INTERFACE OPERATOR(+)
- MODULE PROCEDURE fevar_Addition3
-END INTERFACE OPERATOR(+)
-
!----------------------------------------------------------------------------
! Substraction@SubstractioMethods
!----------------------------------------------------------------------------
@@ -1102,18 +1515,14 @@ END FUNCTION fevar_Addition3
! update: 2021-12-12
! summary: FEVariable = FEVariable - FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Subtraction1(obj1, obj2) RESULT(Ans)
+INTERFACE OPERATOR(-)
+ MODULE PURE FUNCTION fevar_Subtraction1(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Subtraction1
END INTERFACE
-INTERFACE OPERATOR(-)
- MODULE PROCEDURE fevar_Subtraction1
-END INTERFACE OPERATOR(-)
-
!----------------------------------------------------------------------------
! Substraction@SubstractioMethods
!----------------------------------------------------------------------------
@@ -1123,18 +1532,14 @@ END FUNCTION fevar_Subtraction1
! update: 2021-12-12
! summary: FEVariable = FEVariable - RealVal
-INTERFACE
- MODULE PURE FUNCTION fevar_Subtraction2(obj1, val) RESULT(Ans)
+INTERFACE OPERATOR(-)
+ MODULE PURE FUNCTION fevar_Subtraction2(obj1, val) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
REAL(DFP), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Subtraction2
END INTERFACE
-INTERFACE OPERATOR(-)
- MODULE PROCEDURE fevar_Subtraction2
-END INTERFACE OPERATOR(-)
-
!----------------------------------------------------------------------------
! Substraction@SubstractioMethods
!----------------------------------------------------------------------------
@@ -1144,18 +1549,14 @@ END FUNCTION fevar_Subtraction2
! update: 2021-12-12
! summary: FEVariable = RealVal - FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Subtraction3(val, obj1) RESULT(Ans)
+INTERFACE OPERATOR(-)
+ MODULE PURE FUNCTION fevar_Subtraction3(val, obj1) RESULT(ans)
REAL(DFP), INTENT(IN) :: val
CLASS(FEVariable_), INTENT(IN) :: obj1
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Subtraction3
END INTERFACE
-INTERFACE OPERATOR(-)
- MODULE PROCEDURE fevar_Subtraction3
-END INTERFACE OPERATOR(-)
-
!----------------------------------------------------------------------------
! Multiplication@MultiplicationMethods
!----------------------------------------------------------------------------
@@ -1165,18 +1566,14 @@ END FUNCTION fevar_Subtraction3
! update: 2021-12-1
! summary: FEVariable = FEVariable * FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Multiplication1(obj1, obj2) RESULT(Ans)
+INTERFACE OPERATOR(*)
+ MODULE PURE FUNCTION fevar_Multiplication1(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Multiplication1
END INTERFACE
-INTERFACE OPERATOR(*)
- MODULE PROCEDURE fevar_Multiplication1
-END INTERFACE OPERATOR(*)
-
!----------------------------------------------------------------------------
! Multiplication@MultiplicationMethods
!----------------------------------------------------------------------------
@@ -1186,18 +1583,14 @@ END FUNCTION fevar_Multiplication1
! update: 2021-12-12
! summary: FEVariable = FEVariable * Real
-INTERFACE
- MODULE PURE FUNCTION fevar_Multiplication2(obj1, val) RESULT(Ans)
+INTERFACE OPERATOR(*)
+ MODULE PURE FUNCTION fevar_Multiplication2(obj1, val) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
REAL(DFP), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Multiplication2
END INTERFACE
-INTERFACE OPERATOR(*)
- MODULE PROCEDURE fevar_Multiplication2
-END INTERFACE OPERATOR(*)
-
!----------------------------------------------------------------------------
! Multiplication@MultiplicationMethods
!----------------------------------------------------------------------------
@@ -1207,34 +1600,26 @@ END FUNCTION fevar_Multiplication2
! update: 2021-12-12
! summary: FEVariable = Real * FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Multiplication3(val, obj1) RESULT(Ans)
+INTERFACE OPERATOR(*)
+ MODULE PURE FUNCTION fevar_Multiplication3(val, obj1) RESULT(ans)
REAL(DFP), INTENT(IN) :: val
CLASS(FEVariable_), INTENT(IN) :: obj1
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Multiplication3
END INTERFACE
-INTERFACE OPERATOR(*)
- MODULE PROCEDURE fevar_Multiplication3
-END INTERFACE OPERATOR(*)
-
!> author: Vikas Sharma, Ph. D.
! date: 2021-12-12
! update: 2021-12-12
! summary: FEVariable = FEVariable + FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_abs(obj) RESULT(Ans)
+INTERFACE ABS
+ MODULE PURE FUNCTION fevar_abs(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariable_) :: ans
END FUNCTION fevar_abs
END INTERFACE
-INTERFACE ABS
- MODULE PROCEDURE fevar_abs
-END INTERFACE ABS
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -1244,18 +1629,14 @@ END FUNCTION fevar_abs
! update: 2021-12-12
! summary: FEVariable = FEVariable + FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_dot_product(obj1, obj2) RESULT(Ans)
+INTERFACE DOT_PRODUCT
+ MODULE PURE FUNCTION fevar_dot_product(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
TYPE(FEVariable_) :: ans
END FUNCTION fevar_dot_product
END INTERFACE
-INTERFACE DOT_PRODUCT
- MODULE PROCEDURE fevar_dot_product
-END INTERFACE DOT_PRODUCT
-
!----------------------------------------------------------------------------
! Division@DivisionMethods
!----------------------------------------------------------------------------
@@ -1265,18 +1646,14 @@ END FUNCTION fevar_dot_product
! update: 2021-12-12
! summary: FEVariable = FEVariable - FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Division1(obj1, obj2) RESULT(Ans)
+INTERFACE OPERATOR(/)
+ MODULE PURE FUNCTION fevar_Division1(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Division1
END INTERFACE
-INTERFACE OPERATOR(/)
- MODULE PROCEDURE fevar_Division1
-END INTERFACE OPERATOR(/)
-
!----------------------------------------------------------------------------
! Division@DivisionMethods
!----------------------------------------------------------------------------
@@ -1286,18 +1663,14 @@ END FUNCTION fevar_Division1
! update: 2021-12-12
! summary: FEVariable = FEVariable - Real
-INTERFACE
- MODULE PURE FUNCTION fevar_Division2(obj1, val) RESULT(Ans)
+INTERFACE OPERATOR(/)
+ MODULE PURE FUNCTION fevar_Division2(obj1, val) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
REAL(DFP), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Division2
END INTERFACE
-INTERFACE OPERATOR(/)
- MODULE PROCEDURE fevar_Division2
-END INTERFACE OPERATOR(/)
-
!----------------------------------------------------------------------------
! Division@DivisionMethods
!----------------------------------------------------------------------------
@@ -1307,18 +1680,14 @@ END FUNCTION fevar_Division2
! update: 2021-12-12
! summary: FEVariable = Real - FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_Division3(val, obj1) RESULT(Ans)
+INTERFACE OPERATOR(/)
+ MODULE PURE FUNCTION fevar_Division3(val, obj1) RESULT(ans)
REAL(DFP), INTENT(IN) :: val
CLASS(FEVariable_), INTENT(IN) :: obj1
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Division3
END INTERFACE
-INTERFACE OPERATOR(/)
- MODULE PROCEDURE fevar_Division3
-END INTERFACE OPERATOR(/)
-
!----------------------------------------------------------------------------
! Power@PowerMethods
!----------------------------------------------------------------------------
@@ -1328,18 +1697,14 @@ END FUNCTION fevar_Division3
! update: 2021-12-12
! summary: FEVariable = FEVariable + FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_power(obj, n) RESULT(Ans)
+INTERFACE OPERATOR(**)
+ MODULE PURE FUNCTION fevar_power(obj, n) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: n
TYPE(FEVariable_) :: ans
END FUNCTION fevar_power
END INTERFACE
-INTERFACE OPERATOR(**)
- MODULE PROCEDURE fevar_power
-END INTERFACE OPERATOR(**)
-
!----------------------------------------------------------------------------
! Power@PowerMethods
!----------------------------------------------------------------------------
@@ -1349,33 +1714,25 @@ END FUNCTION fevar_power
! update: 2021-12-12
! summary: FEVariable = FEVariable + FEVariable
-INTERFACE
- MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(Ans)
+INTERFACE SQRT
+ MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariable_) :: ans
END FUNCTION fevar_sqrt
END INTERFACE
-INTERFACE SQRT
- MODULE PROCEDURE fevar_sqrt
-END INTERFACE SQRT
-
!> author: Vikas Sharma, Ph. D.
! date: 2021-12-12
! update: 2021-12-12
! summary: FEVariable = NORM2(FEVariable)
-INTERFACE
- MODULE PURE FUNCTION fevar_norm2(obj) RESULT(Ans)
+INTERFACE NORM2
+ MODULE PURE FUNCTION fevar_norm2(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariable_) :: ans
END FUNCTION fevar_norm2
END INTERFACE
-INTERFACE NORM2
- MODULE PROCEDURE fevar_norm2
-END INTERFACE NORM2
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -1385,18 +1742,14 @@ END FUNCTION fevar_norm2
! update: 2021-12-12
! summary: FEVariable = NORM2(FEVariable)
-INTERFACE
- MODULE PURE FUNCTION fevar_isEqual(obj1, obj2) RESULT(Ans)
+INTERFACE OPERATOR(.EQ.)
+ MODULE PURE FUNCTION fevar_isEqual(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
LOGICAL(LGT) :: ans
END FUNCTION fevar_isEqual
END INTERFACE
-INTERFACE OPERATOR(.EQ.)
- MODULE PROCEDURE fevar_isEqual
-END INTERFACE OPERATOR(.EQ.)
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -1406,18 +1759,14 @@ END FUNCTION fevar_isEqual
! update: 2021-12-12
! summary: FEVariable = NORM2(FEVariable)
-INTERFACE
- MODULE PURE FUNCTION fevar_notEqual(obj1, obj2) RESULT(Ans)
+INTERFACE OPERATOR(.NE.)
+ MODULE PURE FUNCTION fevar_notEqual(obj1, obj2) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj1
CLASS(FEVariable_), INTENT(IN) :: obj2
LOGICAL(LGT) :: ans
END FUNCTION fevar_notEqual
END INTERFACE
-INTERFACE OPERATOR(.NE.)
- MODULE PROCEDURE fevar_notEqual
-END INTERFACE OPERATOR(.NE.)
-
!----------------------------------------------------------------------------
! MEAN@MeanMethods
!----------------------------------------------------------------------------
@@ -1426,17 +1775,13 @@ END FUNCTION fevar_notEqual
! date: 27 May 2022
! summary: FEVariable = Mean( obj )
-INTERFACE
+INTERFACE MEAN
MODULE PURE FUNCTION fevar_Mean1(obj) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariable_) :: ans
END FUNCTION fevar_Mean1
END INTERFACE
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean1
-END INTERFACE MEAN
-
!----------------------------------------------------------------------------
! MEAN@MeanMethods
!----------------------------------------------------------------------------
@@ -1445,7 +1790,7 @@ END FUNCTION fevar_Mean1
! date: 27 May 2022
! summary: FEVariable = Mean( obj )
-INTERFACE
+INTERFACE MEAN
MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableScalar_), INTENT(IN) :: dataType
@@ -1453,10 +1798,6 @@ MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans)
END FUNCTION fevar_Mean2
END INTERFACE
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean2
-END INTERFACE MEAN
-
!----------------------------------------------------------------------------
! MEAN@MeanMethods
!----------------------------------------------------------------------------
@@ -1465,7 +1806,7 @@ END FUNCTION fevar_Mean2
! date: 27 May 2022
! summary: FEVariable = Mean( obj )
-INTERFACE
+INTERFACE MEAN
MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableVector_), INTENT(IN) :: dataType
@@ -1473,10 +1814,6 @@ MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans)
END FUNCTION fevar_Mean3
END INTERFACE
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean3
-END INTERFACE MEAN
-
!----------------------------------------------------------------------------
! MEAN@MeanMethods
!----------------------------------------------------------------------------
@@ -1485,7 +1822,7 @@ END FUNCTION fevar_Mean3
! date: 27 May 2022
! summary: FEVariable = Mean( obj )
-INTERFACE
+INTERFACE MEAN
MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans)
CLASS(FEVariable_), INTENT(IN) :: obj
TYPE(FEVariableMatrix_), INTENT(IN) :: dataType
@@ -1493,8 +1830,4 @@ MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans)
END FUNCTION fevar_Mean4
END INTERFACE
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean4
-END INTERFACE MEAN
-
END MODULE FEVariable_Method
diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90
index 8c459eff5..dae820c5f 100644
--- a/src/modules/Geometry/src/ReferenceElement_Method.F90
+++ b/src/modules/Geometry/src/ReferenceElement_Method.F90
@@ -23,8 +23,11 @@ MODULE ReferenceElement_Method
USE BaseType
USE String_Class, ONLY: String
USE GlobalData
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: Display
PUBLIC :: MdEncode
PUBLIC :: ReactEncode
@@ -62,7 +65,8 @@ MODULE ReferenceElement_Method
PUBLIC :: ContainsPoint
PUBLIC :: TotalEntities
PUBLIC :: GetFacetTopology
-PUBLIC :: GetVTKelementType
+PUBLIC :: GetVTKElementType
+PUBLIC :: GetVTKElementType_
PUBLIC :: GetEdgeConnectivity
PUBLIC :: GetFaceConnectivity
PUBLIC :: GetTotalNodes
@@ -75,6 +79,8 @@ MODULE ReferenceElement_Method
PUBLIC :: GetElementIndex
PUBLIC :: Reallocate
PUBLIC :: RefTopoReallocate
+PUBLIC :: RefCoord
+PUBLIC :: RefCoord_
INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_FACES = 6
INTEGER(I4B), PARAMETER, PUBLIC :: PARAM_REFELEM_MAX_EDGES = 12
@@ -98,39 +104,78 @@ MODULE ReferenceElement_Method
INTEGER(I4B) :: tElemTopologyType_2D = 2
INTEGER(I4B) :: tElemTopologyType_3D = 4
INTEGER(I4B) :: tElemTopologyType = 8
- INTEGER(I4B) :: elemTopologyname(8) = [ &
- & Point, &
- & Line, &
- & Triangle, &
- & Quadrangle, &
- & Tetrahedron, Hexahedron, Prism, Pyramid]
+ INTEGER(I4B) :: elemTopologyname(8) = &
+ [Point, Line, Triangle, Quadrangle, Tetrahedron, Hexahedron, Prism, Pyramid]
INTEGER(I4B) :: maxFaces = PARAM_REFELEM_MAX_FACES
INTEGER(I4B) :: maxEdges = PARAM_REFELEM_MAX_EDGES
INTEGER(I4B) :: maxPoints = PARAM_REFELEM_MAX_POINTS
- INTEGER(I4B) :: tCells(8) = [0, 0, 0, 0, 1, 1, 1, 1]
+ INTEGER(I4B) :: tCells(8) = [1, 1, 1, 1, 1, 1, 1, 1]
!! Here cell is a topology for which xidim = 3
- INTEGER(I4B) :: tFaces(8) = [0, 0, 1, 1, 4, 6, 5, 5]
+ INTEGER(I4B) :: tFaces(8) = [0, 2, 3, 4, 4, 6, 5, 5]
!! Here facet is topology entity for which xidim = 2
- INTEGER(I4B) :: tEdges(8) = [0, 0, 3, 4, 6, 12, 9, 8]
+ INTEGER(I4B) :: tEdges(8) = [0, 0, 0, 0, 6, 12, 9, 8]
!! Here edge is topology entity for which xidim = 1
INTEGER(I4B) :: tPoints(8) = [1, 2, 3, 4, 4, 8, 6, 5]
!! A point is topology entity for which xidim = 0
- INTEGER(I4B) :: nne_in_face_triangle(1) = [3]
- !! number of nodes in each face of triangle
- INTEGER(I4B) :: nne_in_face_quadrangle(1) = [4]
- !! number of nodes in each face of quadrangle
- INTEGER(I4B) :: nne_in_face_tetrahedron(4) = [3, 3, 3, 3]
- !! number of nodes in each face of tetrahedron
- INTEGER(I4B) :: nne_in_face_hexahedron(6) = [4, 4, 4, 4, 4, 4]
- !! number of nodes in each face of tetrahedron
- INTEGER(I4B) :: nne_in_face_prism(5) = [3, 4, 4, 4, 3]
- !! number of nodes in each face of tetrahedron
- INTEGER(I4B) :: nne_in_face_pyramid(5) = [4, 3, 3, 3, 3]
- !! number of nodes in each face of tetrahedron
+ !!
+ INTEGER(I4B) :: faceElemTypeLine(2) = Point
+ !! element types of face of Line
+ INTEGER(I4B) :: faceElemTypeTriangle(3) = Line
+ !! element types of faces of triangle
+
+ INTEGER(I4B) :: faceElemTypeQuadrangle(4) = Line
+ !! element types of faces of triangle
+
+ INTEGER(I4B) :: faceElemTypeTetrahedron(4) = Triangle
+ !! element types of faces of triangle
+
+ INTEGER(I4B) :: faceElemTypeHexahedron(6) = Quadrangle
+ !! element types of faces of triangle
+
+ INTEGER(I4B) :: faceElemTypePrism(5) = 0
+ INTEGER(I4B) :: faceElemTypePyramid(5) = 0
+ !! TODO: add faceElemTypePrism and faceElemTypePyramid
+
+ !! element types of faces of triangle
END TYPE ReferenceElementInfo_
-TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = &
- & ReferenceElementInfo_()
+TYPE(ReferenceElementInfo_), PARAMETER :: ReferenceElementInfo = &
+ ReferenceElementInfo_()
+
+!----------------------------------------------------------------------------
+! RefCoord
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-03
+! summary: Returns the coordinate of reference element
+
+INTERFACE
+ MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! Element type
+ CHARACTER(*), INTENT(IN) :: refElem
+ !! "UNIT"
+ !! "BIUNIT"
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ END FUNCTION RefCoord
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE RefCoord_(elemType, refElem, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! Element type
+ CHARACTER(*), INTENT(IN) :: refElem
+ !! "UNIT" ! "BIUNIT"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! xij coordinate
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE RefCoord_
+END INTERFACE
!----------------------------------------------------------------------------
! GetElementIndex@GeometryMethods
@@ -272,8 +317,8 @@ END SUBROUTINE GetFaceConnectivity1
! summary: Returns the element type of each face
INTERFACE GetFaceElemType
- MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, &
- & tFaceNodes)
+ MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, &
+ tFaceNodes)
INTEGER(I4B), INTENT(IN) :: elemType
!! name of element
INTEGER(I4B), INTENT(INOUT) :: faceElemType(:)
@@ -1336,12 +1381,25 @@ END FUNCTION refelem_TotalEntities
! getVTKelementType@VTKMethods
!----------------------------------------------------------------------------
-INTERFACE GetVTKelementType
- MODULE PURE SUBROUTINE get_vtk_elemType(elemType, vtk_type, nptrs)
+INTERFACE GetVTKElementType
+ MODULE PURE SUBROUTINE GetVTKElementType1(elemType, vtk_type, nptrs)
INTEGER(I4B), INTENT(IN) :: elemType
INTEGER(INT8), INTENT(OUT) :: vtk_type
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: nptrs(:)
- END SUBROUTINE get_vtk_elemType
-END INTERFACE GetVTKelementType
+ END SUBROUTINE GetVTKElementType1
+END INTERFACE GetVTKElementType
+
+!----------------------------------------------------------------------------
+! GetVTKElementType@VTKMethods
+!----------------------------------------------------------------------------
+
+INTERFACE GetVTKElementType_
+ MODULE PURE SUBROUTINE GetVTKElementType1_(elemType, vtk_type, nptrs, tsize)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ INTEGER(INT8), INTENT(OUT) :: vtk_type
+ INTEGER(I4B), INTENT(INOUT) :: nptrs(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE GetVTKElementType1_
+END INTERFACE GetVTKElementType_
END MODULE ReferenceElement_Method
diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Geometry/src/ReferenceLine_Method.F90
index 4a9e9b0e9..a609e48b0 100644
--- a/src/modules/Geometry/src/ReferenceLine_Method.F90
+++ b/src/modules/Geometry/src/ReferenceLine_Method.F90
@@ -20,10 +20,16 @@
! summary: This submodule contains method for [[ReferenceLine_]]
MODULE ReferenceLine_Method
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: ReferenceTopology_, &
+ ReferenceElement_, &
+ ReferenceLine_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: Initiate
PUBLIC :: ReferenceLine
PUBLIC :: ReferenceLine_Pointer
@@ -54,11 +60,11 @@ MODULE ReferenceLine_Method
#endif
#ifdef REF_LINE_IS_UNIT
-REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = &
- & RESHAPE([0, 0, 0, 1, 0, 0], [3, 2])
+REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = &
+ RESHAPE([0, 0, 0, 1, 0, 0], [3, 2])
#else
-REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = &
- & RESHAPE([-1, 0, 0, 1, 0, 0], [3, 2])
+REAL(DFP), PARAMETER :: DEFAULT_Ref_LINE_COORD(3, 2) = &
+ RESHAPE([-1, 0, 0, 1, 0, 0], [3, 2])
#endif
!----------------------------------------------------------------------------
@@ -351,8 +357,7 @@ END FUNCTION Reference_Line_Pointer_1
!```
INTERFACE
- MODULE SUBROUTINE HighOrderElement_Line(refelem, order, obj, &
- & ipType)
+ MODULE SUBROUTINE HighOrderElement_Line(refelem, order, obj, ipType)
CLASS(ReferenceElement_), INTENT(IN) :: refelem
!! Linear line element
INTEGER(I4B), INTENT(IN) :: order
diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90
index 09f3e2cd3..4756e86b4 100644
--- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90
+++ b/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90
@@ -20,11 +20,15 @@
! summary: This module contains methods for [[ReferenceQuadrangle_]]
MODULE ReferenceQuadrangle_Method
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
USE BaseType, ONLY: ReferenceQuadrangle_, ReferenceElement_, &
ReferenceTopology_
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: Initiate
PUBLIC :: ReferenceQuadrangle
PUBLIC :: ReferenceQuadrangle_Pointer
@@ -254,8 +258,8 @@ END FUNCTION reference_Quadrangle
! summary: Returns linear Quadrangle element
INTERFACE ReferenceQuadrangle_Pointer
- MODULE FUNCTION reference_Quadrangle_Pointer(NSD, xij, domainName) &
- & RESULT(obj)
+ MODULE FUNCTION reference_Quadrangle_Pointer(NSD, xij, domainName) &
+ RESULT(obj)
INTEGER(I4B), INTENT(IN) :: NSD
REAL(DFP), INTENT(IN), OPTIONAL :: xij(:, :)
CHARACTER(*), OPTIONAL, INTENT(IN) :: domainName
@@ -287,7 +291,7 @@ END FUNCTION reference_Quadrangle_Pointer
INTERFACE
MODULE SUBROUTINE HighorderElement_Quadrangle(refelem, order, obj, &
- & ipType)
+ ipType)
CLASS(ReferenceElement_), INTENT(IN) :: refelem
INTEGER(I4B), INTENT(IN) :: order
CLASS(ReferenceElement_), INTENT(INOUT) :: obj
@@ -448,8 +452,8 @@ END FUNCTION RefQuadrangleCoord
! summary: Returns meta data for global orientation of face
INTERFACE
- MODULE SUBROUTINE FaceShapeMetaData_Quadrangle(face, sorted_face, &
- & faceOrient, localFaces)
+ MODULE SUBROUTINE FaceShapeMetaData_Quadrangle(face, sorted_face, &
+ faceOrient, localFaces)
INTEGER(I4B), INTENT(INOUT) :: face(:)
INTEGER(I4B), INTENT(INOUT) :: sorted_face(:)
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceOrient(:)
@@ -466,8 +470,8 @@ END SUBROUTINE FaceShapeMetaData_Quadrangle
! summary: Returns the element type of each face
INTERFACE
-MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, opt, &
- tFaceNodes)
+ MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, &
+ opt, tFaceNodes)
INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
!! name of element
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
diff --git a/src/modules/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90
index caf86f440..2adf09ce3 100755
--- a/src/modules/GlobalData/src/GlobalData.F90
+++ b/src/modules/GlobalData/src/GlobalData.F90
@@ -16,7 +16,7 @@
MODULE GlobalData
USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, &
- & OUTPUT_UNIT, ERROR_UNIT
+ OUTPUT_UNIT, ERROR_UNIT
IMPLICIT NONE
PUBLIC
@@ -288,13 +288,19 @@ MODULE GlobalData
INTEGER(I4B), PARAMETER :: HierarchyPolynomial = 3
INTEGER(I4B), PARAMETER :: Hierarchy = HierarchyPolynomial
INTEGER(I4B), PARAMETER :: Jacobi = 4
+INTEGER(I4B), PARAMETER :: JacobiPolynomial = Jacobi
INTEGER(I4B), PARAMETER :: Ultraspherical = 5
+INTEGER(I4B), PARAMETER :: UltrasphericalPolynomial = Ultraspherical
INTEGER(I4B), PARAMETER :: Legendre = 6
+INTEGER(I4B), PARAMETER :: LegendrePolynomial = 6
INTEGER(I4B), PARAMETER :: Chebyshev = 7
+INTEGER(I4B), PARAMETER :: ChebyshevPolynomial = 7
INTEGER(I4B), PARAMETER :: Lobatto = 8
+INTEGER(I4B), PARAMETER :: LobattoPolynomial = 8
INTEGER(I4B), PARAMETER :: Orthogonal = 9
INTEGER(I4B), PARAMETER :: OrthogonalPolynomial = Orthogonal
INTEGER(I4B), PARAMETER :: UnscaledLobatto = 10
+INTEGER(I4B), PARAMETER :: UnscaledLobattoPolynomial = 10
INTEGER(I4B), PARAMETER :: HermitPolynomial = 11
!!
!! Quadrature types
@@ -332,23 +338,35 @@ MODULE GlobalData
!!
!! Type of quadrature points
!!
+INTEGER(I4B), PARAMETER :: EquidistanceQP = Equidistance
INTEGER(I4B), PARAMETER :: GaussQP = Gauss
INTEGER(I4B), PARAMETER :: GaussLegendreQP = GaussLegendre
+INTEGER(I4B), PARAMETER :: GaussLegendreLobattoQP = GaussLegendreLobatto
INTEGER(I4B), PARAMETER :: GaussRadauQP = GaussRadau
INTEGER(I4B), PARAMETER :: GaussRadauLeftQP = GaussRadauLeft
INTEGER(I4B), PARAMETER :: GaussRadauRightQP = GaussRadauRight
INTEGER(I4B), PARAMETER :: GaussLobattoQP = GaussLobatto
INTEGER(I4B), PARAMETER :: GaussChebyshevQP = GaussChebyshev
-!!
+INTEGER(I4B), PARAMETER :: GaussChebyshevLobattoQP = GaussChebyshevLobatto
+INTEGER(I4B), PARAMETER :: GaussJacobiQP = GaussJacobi
+INTEGER(I4B), PARAMETER :: GaussJacobiLobattoQP = GaussJacobiLobatto
+INTEGER(I4B), PARAMETER :: GaussUltrasphericalQP = GaussUltraspherical
+INTEGER(I4B), PARAMETER :: GaussUltrasphericalLobattoQP = &
+ GaussUltrasphericalLobatto
INTEGER(I4B), PARAMETER :: ChenBabuska = 22 !! for triangle nodes
+INTEGER(I4B), PARAMETER :: ChenBabuskaQP = 22 !! for triangle nodes
INTEGER(I4B), PARAMETER :: Hesthaven = 23 !! for triangle nodes
+INTEGER(I4B), PARAMETER :: HesthavenQP = 23 !! for triangle nodes
INTEGER(I4B), PARAMETER :: Feket = 24 !! for triangle nodes
-!!
+INTEGER(I4B), PARAMETER :: FeketQP = 24 !! for triangle nodes
INTEGER(I4B), PARAMETER :: BlythPozLegendre = 25 !! for triangle
+INTEGER(I4B), PARAMETER :: BlythPozLegendreQP = 25 !! for triangle
INTEGER(I4B), PARAMETER :: BlythPozChebyshev = 26 !! for triangle
-!!
+INTEGER(I4B), PARAMETER :: BlythPozChebyshevQP = 26 !! for triangle
INTEGER(I4B), PARAMETER :: IsaacLegendre = 27 !! for triangle
+INTEGER(I4B), PARAMETER :: IsaacLegendreQP = 27 !! for triangle
INTEGER(I4B), PARAMETER :: IsaacChebyshev = 28 !! for triangle
+INTEGER(I4B), PARAMETER :: IsaacChebyshevQP = 28 !! for triangle
!!
!! Type of Lagrange Interpolation Points
!!
diff --git a/src/modules/Gnuplot/CMakeLists.txt b/src/modules/Gnuplot/CMakeLists.txt
deleted file mode 100644
index 78b80f677..000000000
--- a/src/modules/Gnuplot/CMakeLists.txt
+++ /dev/null
@@ -1,13 +0,0 @@
-# This file is a part of easifem-base
-# (c) 2021, Vikas Sharma, Ph.D.
-# All right reserved
-#
-# log
-# 16/02/2021 this file was created
-#-----------------------------------------------------------------------
-
-SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
-TARGET_SOURCES(
- ${PROJECT_NAME} PRIVATE
- ${src_path}/ogpf.F90
-)
\ No newline at end of file
diff --git a/src/modules/Gnuplot/src/ogpf.F90 b/src/modules/Gnuplot/src/ogpf.F90
deleted file mode 100644
index ff86405a8..000000000
--- a/src/modules/Gnuplot/src/ogpf.F90
+++ /dev/null
@@ -1,2662 +0,0 @@
-!-------------------------------------------------------------------------------
-! GnuPlot Interface
-!-------------------------------------------------------------------------------
-! Purpose: Object Based Interface to GnuPlot from Fortran (ogpf)
-! Platform: Windows XP/Vista/7/10
-! (It should work on other platforms, see the finalize_plot subroutine below)
-! Language: Fortran 2003 and 2008
-! Requires: 1. Fortran 2003 compiler (e.g gfortran 5, IVF 12.1, ...)
-! There is only two more features needs Fortran 2008 standard
-! execute_command_line and passing internal function as argument.
-! 2. gnuplot 5 and higher (other previous version can be used
-! Author: Mohammad Rahmani
-! Chem Eng Dep., Amirkabir Uni. of Tech
-! Tehran, Ir
-! url: aut.ac.ir/m.rahmani
-! github: github.com/kookma
-! email: m[dot]rahmani[at]aut[dot]ac[dot]ir
-!
-!
-! Acknowledgement:
-! Special thanks to Hagen Wierstorf (http://www.gnuplotting.org)
-! For vluable codes and examples on using gnuplot
-! Some examples and color palletes are provided by gnuplotting.
-!
-
-
-! Revision History
-
-! Revision 0.22
-! Date: Mar 9th, 2018
-! - a new procedure called use_extra_configuration is used to set general gnuplot settings
-! - new type for labels (xlabel, ylabel, zlabel, title,...)
-! - all lables now accept text color, font name, font size, rorate by degree
-! - Secondary axes can use different scale (linear or logarithmic)
-! - subroutine plot2d_matrix_vs_matrix(xmat,ymat)
-! now plots a matrix columns ymat aganist another matrix column xmat
-! - added more examples
-
-! Revision 0.21
-! Date: Mar 8th, 2018
-! - new axes to plot command to use secondary axes added!
-
-
-! Revision: 0.20
-! Date: Feb 20th, 2018
-! - ogpf now supports animation for 2D and 3D plots
-! - rewrite contour and surface plot
-! - select_precision has been merged into ogpf
-! - new add_script procedure replaced old script
-! - new run_script procedure
-! - writestring procedure removed
-! - linespec for plor2d_matrix_vs_plot now is a single dynamic string
-! - splot now uses datablok instead of inline data
-! - meshgrid now support full grid vector
-! - arange a numpy similar function to create a range in the form of [xa, xa+dx, xa+2*dx, ...]
-! - new num2str routines
-
-
-
-! Revision: 0.19
-! Date: Jan 15th, 2018
-! - new contour plot procedure
-
-
-! Revision: 0.18
-! Date: Dec 22th, 2017
-! Major revision
-! - The dynamic string allocation of Fortran 2003 is used (some old compilers
-! does not support this capability)
-! - Multiple windows plot now supported
-! - Multiplot now supported
-! - Gnuplot script file extension is changed from .plt to .gp
-! - Default window size (canvas) changed to 640x480
-! - Persist set to on (true) by default
-! - A separate subroutine is used now to create the output file for gnuplot commands
-! - A separate subroutine is used now to finalize the output
-
-!
-
-
-! Revision: 0.17
-! Date: Dec 18th, 2017
-! Minor corrections
-! - Correct the meshgrid for wrong dy calculation when ygv is sent by two elements.
-! - Remove the subroutine ErrHandler (development postponed to future release)
-
-
-! Revision: 0.16
-! Date: Feb 11th, 2016
-! Minor corrections
-! Correct the lspec processing in plot2D_matrix_vs_vector
-! Now, it is possible to send less line specification and gpf will cycle through lspec
-
-! Revision: 0.15
-! Date: Apr 20th, 2012
-! Minor corrections
-! Use of select_precision module and working precision: wp
-
-! Revision: 0.14
-! Date: Mar 28th, 2012
-! Minor corrections
-! Use of import keyboard and removing the Precision module
-! Length of Title string increased by 80 chars
-
-
-! Revision: 0.13
-! Date: Feb 12th, 2012
-! Minor corrections
-! Added axis method which sets the axis limits for x-axis, y-axis and z-axis
-! Added Precision module
-
-
-
-! Version: 0.12
-! Date: Feb 9th, 2012
-! Minor corrections
-! New semilogx, semilogy, loglog methods
-! New options method, allow to be called several times to set the gnuplot options
-
-
-
-! Version: 0.11
-! Date: Feb 9th, 2012
-! Minor corrections
-! Use of NEWUINT specifier from Fortran 2008
-! Added configuration parameters
-! Extra procedures have been removed
-! Temporary file is now deleted using close(...,status='delete')
-
-!
-! Version: 0.1
-! Date: Jan 5th, 2012
-! First object-based version
-
-MODULE OGPF
-USE GlobalData, ONLY: wp=>DFP, sp=>Real32, dp=>Real64
-IMPLICIT NONE
-PRIVATE
-! Library information
-CHARACTER(LEN=*), PARAMETER :: md_name = 'ogpf libray'
-CHARACTER(LEN=*), PARAMETER :: md_rev = 'Rev. 0.22 of March 9th, 2018'
-CHARACTER(LEN=*), PARAMETER :: md_lic = 'Licence: MIT'
-
-! ogpf Configuration parameters
-! The terminal and font have been set for Windows operating system
-! Correct to meet the requirements on other OS like Linux and Mac.
-CHARACTER(LEN=*), PARAMETER :: gnuplot_term_type = 'wxt'
-!! Output terminal
-CHARACTER(LEN=*), PARAMETER :: gnuplot_term_font = 'verdana,10'
-!! font
-CHARACTER(LEN=*), PARAMETER :: gnuplot_term_size = '640,480'
-!! '960,840' ! plot window size
-CHARACTER(LEN=*), PARAMETER :: gnuplot_output_filename='ogpf_temp_script.gp' !! temporary file for output
-!! extra configuration can be set using ogpf object
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-! module procedure
-! convert integer, real, double precision into string
-INTERFACE num2str
- MODULE PROCEDURE num2str_i4, num2str_r4, num2str_r8
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> 0.22
-! tplabel is a structure for gnuplot labels including
-! title, xlabel, x2label, ylabel, ...
-INTEGER, PARAMETER, PRIVATE :: NOT_INITIALIZED = -32000
-TYPE TPLABEL
- LOGICAL :: has_label = .false.
- CHARACTER(LEN=:), ALLOCATABLE :: lbltext
- CHARACTER(LEN=:), ALLOCATABLE :: lblcolor
- CHARACTER(LEN=:), ALLOCATABLE :: lblfontname
- INTEGER :: lblfontsize = NOT_INITIALIZED
- INTEGER :: lblrotate = NOT_INITIALIZED
-END TYPE TPLABEL
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-! the gpf class implement the object for using gnuplot from fortran in a semi-interactive mode!
-! the fortran actually do the job and write out the commands and data in a single file and then
-! calls the gnuplot by shell command to plot the data
-
-TYPE, PUBLIC :: GPF
- PRIVATE
- !> 0.22
- TYPE(TPLABEL) :: tpplottitle
- TYPE(TPLABEL) :: tpxlabel
- TYPE(TPLABEL) :: tpx2label
- TYPE(TPLABEL) :: tpylabel
- TYPE(TPLABEL) :: tpy2label
- TYPE(TPLABEL) :: tpzlabel
- CHARACTER(LEN=:), ALLOCATABLE :: txtoptions
- !! a long string to store all type of gnuplot options
- CHARACTER(LEN=:), ALLOCATABLE :: txtscript
- !! a long string to store gnuplot script
- CHARACTER(LEN=:), ALLOCATABLE :: txtdatastyle
- !! lines, points, linepoints
- LOGICAL :: hasxrange = .false.
- LOGICAL :: hasx2range = .false.
- LOGICAL :: hasyrange = .false.
- LOGICAL :: hasy2range = .false.
- LOGICAL :: haszrange = .false.
- LOGICAL :: hasoptions = .false.
- LOGICAL :: hasanimation = .false.
- LOGICAL :: hasfilename = .false.
- LOGICAL :: hasfileopen = .false.
- REAL(wp) :: xrange(2), yrange(2), zrange(2)
- REAL(wp) :: x2range(2), y2range(2)
- CHARACTER(len=8) :: plotscale
- ! multiplot parameters
- LOGICAL :: hasmultiplot = .false.
- INTEGER :: multiplot_rows
- INTEGER :: multiplot_cols
- INTEGER :: multiplot_total_plots
- ! animation
- INTEGER :: pause_seconds = 0
- !! keep plot on screen for this value in seconds
- INTEGER :: frame_number
- !! frame number in animation
- ! use for debugging and error handling
- CHARACTER(LEN=:), ALLOCATABLE :: msg
- !! Message from plot procedures
- INTEGER :: status=0
- !!Status from plot procedures
- INTEGER :: file_unit
- !! file unit identifier
- CHARACTER(LEN=:), ALLOCATABLE :: txtfilename
- !! the name of physical file to write the gnuplot script
- ! ogpf preset configuration (kind of gnuplot initialization)
- LOGICAL :: preset_configuration = .true.
- CONTAINS
- PRIVATE
- ! local private procedures
- PROCEDURE, PASS, PRIVATE :: preset_gnuplot_config
- PROCEDURE, PASS, PRIVATE :: plot2d_vector_vs_vector
- PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_vector
- PROCEDURE, PASS, PRIVATE :: plot2d_matrix_vs_matrix
- PROCEDURE, PASS, PRIVATE :: semilogxv
- PROCEDURE, PASS, PRIVATE :: semilogxm
- PROCEDURE, PASS, PRIVATE :: semilogyv
- PROCEDURE, PASS, PRIVATE :: semilogym
- PROCEDURE, PASS, PRIVATE :: loglogv
- PROCEDURE, PASS, PRIVATE :: loglogm
- !> 0.22
- PROCEDURE, PASS, PRIVATE :: set_label
- ! public procedures
- PROCEDURE, PASS, PUBLIC :: options => set_options
- PROCEDURE, PASS, PUBLIC :: title => set_plottitle
- PROCEDURE, PASS, PUBLIC :: xlabel => set_xlabel
- PROCEDURE, PASS, PUBLIC :: x2label => set_x2label
- PROCEDURE, PASS, PUBLIC :: ylabel => set_ylabel
- PROCEDURE, PASS, PUBLIC :: y2label => set_y2label
- PROCEDURE, PASS, PUBLIC :: zlabel => set_zlabel
- PROCEDURE, PASS, PUBLIC :: axis => set_axis
- PROCEDURE, PASS, PUBLIC :: axis_sc => set_secondary_axis
- PROCEDURE, PASS, PUBLIC :: filename => set_filename
- PROCEDURE, PASS, PUBLIC :: reset => reset_to_defaults
- PROCEDURE, PASS, PUBLIC :: preset => use_preset_configuration
- PROCEDURE, PASS, PUBLIC :: multiplot => sub_multiplot
- GENERIC, PUBLIC :: plot => &
- & plot2d_vector_vs_vector, &
- & plot2d_matrix_vs_vector, &
- & plot2d_matrix_vs_matrix
- GENERIC, PUBLIC :: semilogx => semilogxv, semilogxm
- GENERIC, PUBLIC :: semilogy => semilogyv, semilogym
- GENERIC, PUBLIC :: loglog => loglogv, loglogm
- PROCEDURE, PASS, PUBLIC :: surf => splot ! 3D surface plot
- PROCEDURE, PASS, PUBLIC :: lplot => lplot3d ! 3D line plot
- PROCEDURE, PASS, PUBLIC :: contour => cplot ! contour plot
- PROCEDURE, PASS, PUBLIC :: fplot => function_plot
- PROCEDURE, PASS, PUBLIC :: add_script => addscript
- PROCEDURE, PASS, PUBLIC :: run_script => runscript
- PROCEDURE, PASS, PUBLIC :: animation_start => sub_animation_start
- PROCEDURE, PASS, PUBLIC :: animation_show => sub_animation_show
-END TYPE GPF
-
-CONTAINS
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section One: Set/Get Methods for ogpf object
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
- subroutine use_preset_configuration(this,flag)
- !..............................................................................
- !Set a flag to tell ogpf if the customized gnuplot configuration should
- !be used
- !..............................................................................
-
- class(gpf):: this
- logical, intent(in) :: flag
-
- ! default is true
- this%preset_configuration = flag
-
- end subroutine use_preset_configuration
-
-
-
- subroutine set_filename(this,string)
- !..............................................................................
- !Set a file name for plot command output
- !This file can be used later by gnuplot as an script file to reproduce the plot
- !..............................................................................
-
- class(gpf):: this
- character(len=*), intent(in) :: string
-
- this%txtfilename = trim(string)
- this%hasfilename = .true.
-
- end subroutine set_filename
-
-
- subroutine set_options(this,stropt)
- !..............................................................................
- ! Set the plot options. This is a very powerfull procedure accepts many types
- ! of gnuplot command and customization
- !..............................................................................
-
- class(gpf):: this
- character(len=*), intent(in) :: stropt
-
- if(.not.allocated(this%txtoptions))this%txtoptions=''
- if (len_trim(this%txtoptions) == 0 ) then
- this%txtoptions = '' ! initialize string
- end if
- if ( len_trim(stropt)>0 ) then
- this%txtoptions = this%txtoptions // splitstr(stropt)
- end if
-
- this%hasoptions=.true.
-
- end subroutine set_options
-
-
-
-
- subroutine set_axis(this,rng)
- !..............................................................................
- !Set the axes limits in form of [xmin, xmax, ymin, ymax, zmin, zmax]
- !..............................................................................
-
- class(gpf):: this
- real(wp), intent(in) :: rng(:)
- integer :: n
- n=size(rng,dim=1)
- select case(n)
- case(2) !Only the range for x-axis has been sent
- this%hasxrange=.true.
- this%xrange=rng(1:2)
- case(4)
- this%hasxrange=.true.
- this%hasyrange=.true.
- this%xrange=rng(1:2)
- this%yrange=rng(3:4)
- case(6)
- this%hasxrange=.true.
- this%hasyrange=.true.
- this%haszrange=.true.
- this%xrange=rng(1:2)
- this%yrange=rng(3:4)
- this%zrange=rng(5:6)
- case default
- print*, 'gpf error: wrong axis range setting!'
- return
- end select
-
- end subroutine set_axis
-
-
- subroutine set_secondary_axis(this,rng)
- !..............................................................................
- !Set the secondary axes limits in form of [x2min, x2max, y2min, y2max]
- !..............................................................................
-
- class(gpf):: this
- real(wp), intent(in) :: rng(:)
- integer :: n
- n=size(rng,dim=1)
- select case(n)
- case(2) !Only the range for x2-axis has been sent
- this%hasx2range=.true.
- this%x2range=rng(1:2)
- case(4)
- this%hasx2range=.true.
- this%hasy2range=.true.
- this%x2range=rng(1:2)
- this%y2range=rng(3:4)
- case default
- print*, 'gpf error: wrong axis range setting!'
- return
- end select
-
- end subroutine set_secondary_axis
-
-
- subroutine set_plottitle(this, string, textcolor, font_size, font_name, rotate)
- !..............................................................................
- !Set the plot title
- !..............................................................................
- class(gpf):: this
- character(len=*), intent(in) :: string
- character(len=*), intent(in), optional :: textcolor
- integer, optional :: font_size
- character(len=*), intent(in), optional :: font_name
- integer, optional :: rotate
-
- call this%set_label('plot_title', string, textcolor, font_size, font_name, rotate)
-
- end subroutine set_plottitle
-
-
- subroutine set_xlabel(this, string, textcolor, font_size, font_name, rotate)
- !..............................................................................
- !Set the xlabel
- !..............................................................................
- class(gpf):: this
- character(len=*), intent(in) :: string
- character(len=*), intent(in), optional :: textcolor
- integer, optional :: font_size
- character(len=*), intent(in), optional :: font_name
- integer, optional :: rotate
-
- call this%set_label('xlabel', string, textcolor, font_size, font_name, rotate)
-
- end subroutine set_xlabel
-
-
- subroutine set_x2label(this, string, textcolor, font_size, font_name, rotate)
- !..............................................................................
- !Set the x2label
- !..............................................................................
- class(gpf):: this
- character(len=*), intent(in) :: string
- character(len=*), intent(in), optional :: textcolor
- integer, optional :: font_size
- character(len=*), intent(in), optional :: font_name
- integer, optional :: rotate
-
- call this%set_label('x2label', string, textcolor, font_size, font_name, rotate)
-
- end subroutine set_x2label
-
-
- subroutine set_ylabel(this, string, textcolor, font_size, font_name, rotate)
- !..............................................................................
- !Set the ylabel
- !..............................................................................
- class(gpf):: this
- character(len=*), intent(in) :: string
- character(len=*), intent(in), optional :: textcolor
- integer, optional :: font_size
- character(len=*), intent(in), optional :: font_name
- integer, optional :: rotate
-
- call this%set_label('ylabel', string, textcolor, font_size, font_name, rotate)
-
- end subroutine set_ylabel
-
-
-
- subroutine set_y2label(this, string, textcolor, font_size, font_name, rotate)
- !..............................................................................
- !Set the y2label
- !..............................................................................
- class(gpf):: this
- character(len=*), intent(in) :: string
- character(len=*), intent(in), optional :: textcolor
- integer, optional :: font_size
- character(len=*), intent(in), optional :: font_name
- integer, optional :: rotate
-
- call this%set_label('y2label', string, textcolor, font_size, font_name, rotate)
-
- end subroutine set_y2label
-
-
- subroutine set_zlabel(this, string, textcolor, font_size, font_name, rotate)
- !..............................................................................
- !Set the zlabel
- !..............................................................................
- class(gpf):: this
- character(len=*), intent(in) :: string
- character(len=*), intent(in), optional :: textcolor
- integer, optional :: font_size
- character(len=*), intent(in), optional :: font_name
- integer, optional :: rotate
-
- call this%set_label('zlabel', string, textcolor, font_size, font_name, rotate)
-
- end subroutine set_zlabel
-
-
- !> 0.22
-
- subroutine set_label(this, lblname, lbltext, lblcolor, font_size, font_name, rotate)
- !..............................................................................
- ! Set the text, color, font, size and rotation for labels including
- ! title, xlabel, x2label, ylabel, ....
- !..............................................................................
-
- class(gpf):: this
- character(len=*), intent(in) :: lblname
- character(len=*), intent(in) :: lbltext
- character(len=*), intent(in), optional :: lblcolor
- character(len=*), intent(in), optional :: font_name
- integer, optional :: font_size
- integer, optional :: rotate
-
- ! local variable
- type(tplabel) :: label
-
- label%has_label = .true.
- label%lbltext = trim(lbltext)
-
- if (present(lblcolor)) then
- label%lblcolor = lblcolor
- end if
-
- if (present(font_name)) then
- label%lblfontname = font_name
- else
- if(.not.allocated(label%lblfontname))then
- label%lblfontname = ''
- endif
- end if
-
- if (present(font_size)) then
- label%lblfontsize = font_size
- end if
-
- if (present(rotate)) then
- label%lblrotate = rotate
- end if
-
- select case (lblname)
- case ('xlabel')
- this%tpxlabel = label
- case ('x2label')
- this%tpx2label = label
- case ('ylabel')
- this%tpylabel = label
- case ('y2label')
- this%tpy2label = label
- case ('zlabel')
- this%tpzlabel = label
- case ('plot_title')
- this%tpplottitle = label
- end select
-
-
- end subroutine set_label
-
-
-
- subroutine reset_to_defaults(this)
- !..............................................................................
- !Reset all ogpf properties (params to their default values
- !...............................................................................
- class(gpf):: this
-
- this%preset_configuration = .true.
- this%txtfilename = gnuplot_output_filename
-
- if (allocated(this%txtoptions)) deallocate(this%txtoptions)
- if (allocated(this%txtscript)) deallocate(this%txtscript)
- if (allocated(this%txtdatastyle)) deallocate(this%txtdatastyle)
- if (allocated(this%msg)) deallocate(this%msg)
-
- this%hasoptions = .false.
-
- this%hasxrange = .false.
- this%hasx2range = .false.
- this%hasyrange = .false.
- this%hasy2range = .false.
- this%haszrange = .false.
-
- this%pause_seconds = 0
- this%status = 0
- this%hasanimation = .false.
- this%hasfileopen = .false.
- this%hasmultiplot = .false.
-
- this%plotscale = ''
- this%tpplottitle%has_label =.false.
- this%tpxlabel%has_label =.false.
- this%tpx2label%has_label =.false.
- this%tpylabel%has_label =.false.
- this%tpy2label%has_label =.false.
- this%tpzlabel%has_label =.false.
-
-
- end subroutine reset_to_defaults
-
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section Two: Main Plotting Routines
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
- subroutine sub_multiplot(this, rows, cols)
- !..............................................................................
- ! This subroutine sets flag and number of rows and columns in case
- ! of multiplot layout
- !..............................................................................
-
- class(gpf):: this
- integer, intent(in) :: rows
- integer, intent(in) :: cols
-
- ! ogpf does not support multiplot in animation mode
- if (this%hasanimation) then
- print*, md_name // ': ogpf does not support animation in multiplot mode'
- stop
- end if
-
- ! set multiplot cols and rows
- if (rows> 0 ) then
- this%multiplot_rows = rows
- else
-
- end if
- if (cols > 0 ) then
- this%multiplot_cols = cols
- else
-
- end if
-
- ! set the multiplot layout flag and plot numbers
- this%hasmultiplot = .true.
- this%multiplot_total_plots = 0
-
- ! create the ouput file for writting gnuplot script
- call create_outputfile(this)
-
-
- end subroutine sub_multiplot
-
-
- subroutine plot2d_vector_vs_vector(this, x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4, axes4 )
- !..............................................................................
- ! This procedure plots:
- ! 1. A vector against another vector (xy plot)
- ! 2. A vector versus its element indices (yi plot).
- ! 3. Can accept up to 4 data sets as x,y pairs!
- ! Arguments
- ! xi, yi vectors of data series,
- ! lsi a string maximum 80 characters containing the line specification,
- ! legends, ...
- ! axesi is the axes for plotting: secondary axes are x2, and y2
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x1(:) ! vector of data for x
- real(wp), intent(in), optional :: y1(:) ! vector of data for y
- character(len=*), intent(in), optional :: ls1 ! line specification
- character(len=*), intent(in), optional :: axes1
-
- real(wp), intent(in), dimension(:), optional :: x2
- real(wp), intent(in), dimension(:), optional :: y2
- character(len=*), intent(in), optional :: ls2
- character(len=*), intent(in), optional :: axes2
-
- real(wp), intent(in), dimension(:), optional :: x3
- real(wp), intent(in), dimension(:), optional :: y3
- character(len=*), intent(in), optional :: ls3
- character(len=*), intent(in), optional :: axes3
-
- real(wp), intent(in), dimension(:), optional :: x4
- real(wp), intent(in), dimension(:), optional :: y4
- character(len=*), intent(in), optional :: ls4
- character(len=*), intent(in), optional :: axes4
-
- ! Local variables
- !----------------------------------------------------------------------
-
- integer:: nx1
- integer:: ny1
- integer:: nx2
- integer:: ny2
- integer:: nx3
- integer:: ny3
- integer:: nx4
- integer:: ny4
- integer:: number_of_plots
- character(len=3):: plottype
- integer:: i
- character(len=80) :: pltstring(4) ! Four 80 characters string
-
- !Initialize variables
- plottype = ''
- pltstring = ''
-
- ! Check the input
- nx1=size(x1)
- if ((present(y1) )) then
- ny1=size(y1)
- if (checkdim(nx1,ny1)) then
- plottype='xy1'
- number_of_plots=1
- else
- print*, md_name // ':plot2d_vector_vs_vector:' // 'length of x1 and y1 does not match'
- return
- end if
- else !plot only x againest its element indices
- plottype='xi'
- number_of_plots=1
- end if
-
- !Process line spec and axes set for first data set if present
- call process_linespec(1, pltstring(1), ls1, axes1)
-
-
- if (present(x2) .and. present (y2)) then
- nx2=size(x2)
- ny2=size(y2)
- if (checkdim(nx2,ny2)) then
- plottype='xy2'
- number_of_plots=2
- else
- return
- end if
- !Process line spec for 2nd data set if present
- call process_linespec(2, pltstring(2), ls2, axes2)
- end if
-
- if (present(x3) .and. present (y3)) then
- nx3=size(x3)
- ny3=size(y3)
- if (checkdim(nx3,ny3)) then
- plottype='xy3'
- number_of_plots=3
- else
- return
- end if
- !Process line spec for 3rd data set if present
- call process_linespec(3, pltstring(3), ls3, axes3)
- end if
-
- if (present(x4) .and. present (y4)) then
- nx4=size(x4)
- ny4=size(y4)
- if (checkdim(nx4,ny4)) then
- plottype='xy4'
- number_of_plots=4
- else
- return
- end if
- !Process line spec for 4th data set if present
- call process_linespec(4, pltstring(4), ls4, axes4)
- end if
-
-
- call create_outputfile(this)
-
- ! Write plot title, axis labels and other annotations
- call processcmd(this)
-
- ! Write plot command and line styles and legend if any
- if (number_of_plots ==1) then
- write ( this%file_unit, '(a)' ) trim(pltstring(1))
- else
- write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_plots-1)
- write ( this%file_unit, '(a)' ) trim(pltstring(number_of_plots))
- end if
- ! Write xy data into file
- select case (plottype)
- case ('xi')
- call write_xydata(this%file_unit,nx1,x1)
- case ('xy1')
- call write_xydata(this%file_unit,nx1,x1,y1)
- case ('xy2')
- call write_xydata(this%file_unit,nx1,x1,y1)
- call write_xydata(this%file_unit,nx2,x2,y2)
- case ('xy3')
- call write_xydata(this%file_unit,nx1,x1,y1)
- call write_xydata(this%file_unit,nx2,x2,y2)
- call write_xydata(this%file_unit,nx3,x3,y3)
- case ('xy4')
- call write_xydata(this%file_unit,nx1,x1,y1)
- call write_xydata(this%file_unit,nx2,x2,y2)
- call write_xydata(this%file_unit,nx3,x3,y3)
- call write_xydata(this%file_unit,nx4,x4,y4)
- end select
-
- !> Rev 0.2
- ! if there is no animation finalize
- if (.not. (this%hasanimation)) then
- call finalize_plot(this)
- else
- write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds
- end if
-
-
- !: End of plot2D_vector_vs_vector
- end subroutine plot2d_vector_vs_vector
-
-
-
- subroutine plot2d_matrix_vs_vector(this, xv,ymat, lspec)
- !..............................................................................
- ! plot2D_matrix_vs_vector accepts a vector xv and a matrix ymat and plots
- ! columns of ymat against xv. lspec is an optional array defines the line
- ! specification for each data series. If a single element array is sent for
- ! lspec then all series are plotted using the same linespec
- !..............................................................................
-
- implicit none
- class(gpf):: this
- ! Input arrays
- real(wp), intent(in) :: xv(:)
- real(wp), intent(in) :: ymat(:,:)
- character(len=*), intent(in), optional :: lspec
- !----------------------------------------------------------------------
- ! Local variables
- integer:: nx
- integer:: ny
- integer:: ns
- integer:: number_of_curves
- integer:: i
- integer:: j
- integer:: ierr
- character(len=80), allocatable :: pltstring(:), lst(:)
- !
-
- !*******************************************************************************
- ! Check the input
- nx=size(xv)
- ny=size(ymat,dim=1)
- if (.not. checkdim(nx,ny)) then
- print*, md_name // ':plot2d_matrix_vs_vector:' // 'The length of arrays does not match'
- return
- end if
- ! create the outfile to write the gnuplot script
- call create_outputfile(this)
-
- ! Write titles and other annotations
- call processcmd(this)
-
- ! Write plot command and line styles and legend if any
- number_of_curves=size(ymat,dim=2)
- allocate(pltstring(number_of_curves), stat=ierr)
- if (ierr /=0) then
- print*, 'allocation error'
- return
- end if
-
- ! assume no linespec is available
- pltstring(1:number_of_curves) = ''
-
- if ( present(lspec) ) then
-
- call splitstring2array(lspec,lst,';')
- ns = size(lst, dim=1)
-
- if (ns == number_of_curves) then
- ! there is a linespec for each curve
- pltstring = lst
- elseif (ns < number_of_curves) then
- ! not enough linespec
- do i=1, ns
- pltstring(i) = lst(i)
- end do
- else ! ns > number_of curves
- print*, 'ogpf: plot2d_matrix_vs_vector: wrong number of linespec'
- print*, 'semicolon ";" acts as delimiter, check the linespec'
- end if
- end if
-
- if ( present(lspec) ) then
-
- call process_linespec(1,pltstring(1),lst(1))
- ns=size(lst)
- ! gpf will cylce through line specification, if number of specification passed
- ! is less than number of plots
- do i=1, number_of_curves
- j=mod(i-1, ns) + 1
- call process_linespec(i, pltstring(i), lst(j))
- end do
- else !No lspec is available
- pltstring(1)=' plot "-" notitle,'
- pltstring(2:number_of_curves-1)='"-" notitle,'
- pltstring(number_of_curves)='"-" notitle'
- end if
-
- ! Write plot command and line styles and legend if any
- write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1)
- write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves))
-
- ! Write data into script file
- do j=1, number_of_curves
- do i = 1, nx
- write ( this%file_unit, * ) xv(i),ymat(i,j)
- end do
- write ( this%file_unit, '(a)' ) 'e' !end of jth set of data
- end do
-
-
- !> Rev 0.2
- ! if there is no animation finalize
- if (.not. (this%hasanimation)) then
- call finalize_plot(this)
- else
- write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds
- end if
-
- !Release memory
- if (allocated(pltstring)) then
- deallocate(pltstring)
- end if
- !: End of plot2D_matrix_vs_vector
- end subroutine plot2d_matrix_vs_vector
-
-
-
- subroutine plot2d_matrix_vs_matrix(this, xmat,ymat, lspec)
- !..............................................................................
- ! plot2D_matrix_vs_matrix accepts a matrix xmat and a matrix ymat and plots
- ! columns of ymat against columns of xmat. lspec is an optional array defines
- ! the line specification for each data series. If a single element array is
- ! sent for lspec then all series are plotted using the same linespec
- !..............................................................................
-
- implicit none
- class(gpf):: this
- ! Input arrays
- real(wp), intent(in) :: xmat(:,:)
- real(wp), intent(in) :: ymat(:,:)
- character(len=*), intent(in), optional :: lspec
- !----------------------------------------------------------------------
- ! Local variables
- integer:: mx, nx
- integer:: my, ny
- integer:: ns
- integer:: number_of_curves
- integer:: i
- integer:: j
- integer:: ierr
- character(len=80), allocatable :: pltstring(:), lst(:)
- !
-
- !*******************************************************************************
- ! Check the input
- ! check number of rows
- mx=size(xmat,dim=1)
- my=size(ymat,dim=1)
- if (.not. checkdim(mx,my)) then
- print*, md_name // ':plot2d_matrix_vs_matrix:' // 'The length of arrays does not match'
- return
- end if
- ! check number of rows
- nx=size(xmat,dim=2)
- ny=size(ymat,dim=2)
- if (.not. checkdim(nx,ny)) then
- print*, 'gpf error: The number of columns are different, check xmat, ymat'
- return
- end if
-
-
- ! create the outfile to write the gnuplot script
- call create_outputfile(this)
-
- ! Write titles and other annotations
- call processcmd(this)
-
- ! Write plot command and line styles and legend if any
- number_of_curves=size(ymat,dim=2)
- allocate(pltstring(number_of_curves), stat=ierr)
- if (ierr /=0) then
- print*, 'allocation error'
- return
- end if
-
- ! assume no linespec is available
- pltstring(1:number_of_curves) = ''
-
- if ( present(lspec) ) then
-
- call splitstring2array(lspec,lst,';')
- ns = size(lst, dim=1)
-
- if (ns == number_of_curves) then
- ! there is a linespec for each curve
- pltstring = lst
- elseif (ns < number_of_curves) then
- ! not enough linespec
- do i=1, ns
- pltstring(i) = lst(i)
- end do
- else ! ns > number_of curves
- print*, md_name // ': plot2d_matrix_vs_matrix:'//' wrong number of linespec'
- print*, 'semicolon ";" acts as delimiter, check the linespec'
- end if
- end if
-
- if ( present(lspec) ) then
-
- call process_linespec(1,pltstring(1),lst(1))
- ns=size(lst)
- ! gpf will cylce through line specification, if number of specification passed
- ! is less than number of plots
- do i=1, number_of_curves
- j=mod(i-1, ns) + 1
- call process_linespec(i, pltstring(i), lst(j))
- end do
- else !No lspec is available
- pltstring(1)=' plot "-" notitle,'
- pltstring(2:number_of_curves-1)='"-" notitle,'
- pltstring(number_of_curves)='"-" notitle'
- end if
-
- ! Write plot command and line styles and legend if any
- write ( this%file_unit, '(a)' ) ( trim(pltstring(i)) // ' \' , i=1, number_of_curves-1)
- write ( this%file_unit, '(a)' ) trim(pltstring(number_of_curves))
-
- ! Write data into script file
- do j=1, number_of_curves
- do i = 1, mx
- write ( this%file_unit, * ) xmat(i,j),ymat(i,j)
- end do
- write ( this%file_unit, '(a)' ) 'e' !end of jth set of data
- end do
-
- !> Rev 0.2
- ! if there is no animation finalize
- if (.not. (this%hasanimation)) then
- call finalize_plot(this)
- else
- write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds
- end if
-
- !Release memory
- if (allocated(pltstring)) then
- deallocate(pltstring)
- end if
- !: End of plot2D_matrix_vs_vector
- end subroutine plot2d_matrix_vs_matrix
-
-
- subroutine splot(this, x, y, z, lspec, palette)
- !..............................................................................
- ! splot create a surface plot
- ! datablock is used instead of gnuplot inline file "-"
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x(:,:)
- real(wp), intent(in), optional :: y(:,:)
- real(wp), intent(in), optional :: z(:,:)
- character(len=*), intent(in), optional :: lspec
- character(len=*), intent(in), optional :: palette
-
- ! Local variables
- !----------------------------------------------------------------------
- integer:: ncx
- integer:: nrx
- integer:: i
- integer:: j
- logical:: xyz_data
- character(len=80):: pltstring
- character(len=*), parameter :: datablock = '$xyz'
-
- pltstring=''
- ! Check the input data
- ncx=size(x,dim=2)
- nrx=size(x,dim=1)
- if (present(y) .and. present(z)) then
- xyz_data=.true.
- elseif (present(y)) then
- print*, "gpf error: Z matrix was not sent to 3D plot routine"
- return
- else
- xyz_data=.false.
- end if
-
- ! set default line style for 3D plot, can be overwritten
- this%txtdatastyle = 'lines'
- ! create the script file for writting gnuplot commands and data
- call create_outputfile(this)
-
- ! Write titles and other annotations
- call processcmd(this)
-
- ! Write xy data into file
- write ( this%file_unit, '(a)' ) '#data x y z'
- ! Rev 0.20
- ! write the $xyz datablocks
- write( this%file_unit, '(a)' ) datablock // ' << EOD'
- if (xyz_data) then
- do j=1,ncx
- do i=1, nrx
- write ( this%file_unit, * ) x(i,j), y(i,j), z(i,j)
- enddo
- write( this%file_unit, '(a)' ) !put an empty line
- enddo
- write ( this%file_unit, '(a)' ) 'EOD' !end of datablock
- else !only Z has been sent (i.e. single matrix data)
- do j=1,ncx
- do i=1, nrx
- write ( this%file_unit, * ) i, j, x(i,j)
- enddo
- write( this%file_unit, '(a)' ) !put an empty line
- enddo
- write ( this%file_unit, '(a)' ) 'EOD' !end of datablock
- end if
-
-
- !write the color palette into gnuplot script file
- if (present(palette)) then
- write ( this%file_unit, '(a)' ) color_palettes(palette)
- write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec
- end if
-
-
- if ( present(lspec) ) then
- if (hastitle(lspec)) then
- pltstring='splot ' // datablock // ' ' // trim(lspec)
- else
- pltstring='splot ' // datablock // ' notitle '//trim(lspec)
- end if
- else
- pltstring='splot ' // datablock // ' notitle '
- end if
-
- write ( this%file_unit, '(a)' ) trim(pltstring)
-
-
- !> Rev 0.2: animation
- ! if there is no animation finalize
- if (.not. (this%hasanimation)) then
- call finalize_plot(this)
- else
- write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds
- end if
-
- !: End of splot
- end subroutine splot
-
-
- subroutine cplot(this, x, y, z, lspec, palette)
- !..............................................................................
- ! Rev 0.19
- ! cplot creates a contour plot based on the three dimensional data
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x(:,:)
- real(wp), intent(in), optional :: y(:,:)
- real(wp), intent(in), optional :: z(:,:)
- character(len=*), intent(in), optional :: lspec
- character(len=*), intent(in), optional :: palette
-
- ! Local variables
- !----------------------------------------------------------------------
-
- integer:: ncx
- integer:: nrx
- integer:: i
- integer:: j
- logical:: xyz_data
- character(len=80):: pltstring
- character(len=*), parameter :: datablock = '$xyz'
- ! character(len=*), parameter :: cntr_table = '$xyz_contour'
-
- pltstring=''
- ! Check the input data
- ncx=size(x,dim=2)
- nrx=size(x,dim=1)
- if (present(y) .and. present(z)) then
- xyz_data=.true.
- elseif (present(y)) then
- print*, "gpf error: Z matrix was not sent to 3D plot routine"
- return
- else
- xyz_data=.false.
- end if
-
- ! set default line style for 3D plot, can be overwritten
- this%txtdatastyle = 'lines'
- ! create the script file for writting gnuplot commands and data
- call create_outputfile(this)
-
- ! Write titles and other annotations
- call processcmd(this)
-
- ! Write xy data into file
- write ( this%file_unit, '(a)' ) '#data x y z'
- ! write the $xyz datablocks
- write( this%file_unit, '(a)' ) datablock // ' << EOD'
- if (xyz_data) then
- do j=1,ncx
- do i=1, nrx
- write ( this%file_unit, fmt=* ) x(i,j), y(i,j), z(i,j)
- enddo
- write( this%file_unit, '(a)' ) !put an empty line
- enddo
- write ( this%file_unit, '(a)' ) 'EOD' !end of datablock
- else !only Z has been sent (i.e. single matrix data)
- do j=1,ncx
- do i=1, nrx
- write ( this%file_unit, fmt=* ) i, j, x(i,j)
- enddo
- write( this%file_unit, '(a)' ) !put an empty line
- enddo
- write ( this%file_unit, '(a)' ) 'EOD' !end of datablock
- end if
-
-
- ! create the contour lines
- write ( this%file_unit, '(a)' ) ! empty line
- write ( this%file_unit, '(a)' ) '# create the contour'
- write ( this%file_unit, '(a)' ) 'set contour base'
- write ( this%file_unit, '(a)' ) 'set cntrparam levels 14'
- write ( this%file_unit, '(a)' ) 'unset surface'
- write ( this%file_unit, '(a)' ) 'set view map'
-
-
- !write the color palette into gnuplot script file
- if (present(palette)) then
- write ( this%file_unit, '(a)' ) color_palettes(palette)
- write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec
- end if
-
-
- write ( this%file_unit, '(a)' ) ! empty line
-
- if ( present(lspec) ) then
- if (hastitle(lspec)) then
- pltstring='splot ' // datablock // ' ' // trim(lspec)
- else
- pltstring='splot ' // datablock // ' notitle '//trim(lspec)
- end if
- else
- pltstring='splot ' // datablock // ' notitle '
- end if
-
- write ( this%file_unit, '(a)' ) trim(pltstring)
-
- !> Rev 0.20
- ! if there is no animation finalize
- if (.not. (this%hasanimation)) then
- call finalize_plot(this)
- else
- write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds
- end if
-
- !: End of cplot
- end subroutine cplot
-
- subroutine lplot3d(this, x, y, z, lspec, palette)
- !..............................................................................
- ! lplot3d create a line plot in 3d
- ! datablock is used instead of gnuplot inline file "-"
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x(:)
- real(wp), intent(in), optional :: y(:)
- real(wp), intent(in), optional :: z(:)
- character(len=*), intent(in), optional :: lspec
- character(len=*), intent(in), optional :: palette
-
- ! Local variables
- !----------------------------------------------------------------------
- integer:: ncx
- integer:: nrx
- integer:: i
- integer:: j
- logical:: xyz_data
- character(len=80):: pltstring
- character(len=*), parameter :: datablock = '$xyz'
-
- pltstring=''
- ! Check the input data
- nrx=size(x)
- if (present(y) .and. present(z)) then
- xyz_data=.true.
- elseif (present(y)) then
- print*, "gpf error: Z matrix was not sent to 3D plot routine"
- return
- else
- xyz_data=.false.
- end if
-
- ! set default line style for 3D plot, can be overwritten
- this%txtdatastyle = 'lines'
- ! create the script file for writing gnuplot commands and data
- call create_outputfile(this)
-
- ! Write titles and other annotations
- call processcmd(this)
-
- ! Write xy data into file
- write ( this%file_unit, '(a)' ) '#data x y z'
- ! Rev 0.20
- ! write the $xyz datablocks
- write( this%file_unit, '(a)' ) datablock // ' << EOD'
- if (xyz_data) then
- do i=1, nrx
- write ( this%file_unit, * ) x(i), y(i), z(i)
- enddo
- write( this%file_unit, '(a)' ) !put an empty line
- write ( this%file_unit, '(a)' ) 'EOD' !end of datablock
- else !only Z has been sent (i.e. single matrix data)
- do i=1, nrx
- write ( this%file_unit, * ) i, x(i)
- enddo
- write( this%file_unit, '(a)' ) !put an empty line
- write ( this%file_unit, '(a)' ) 'EOD' !end of datablock
- end if
-
-
- !write the color palette into gnuplot script file
- if (present(palette)) then
- write ( this%file_unit, '(a)' ) color_palettes(palette)
- write ( this%file_unit, '(a)' ) 'set pm3d' ! a conflict with lspec
- end if
-
-
- if ( present(lspec) ) then
- if (hastitle(lspec)) then
- pltstring='splot ' // datablock // ' ' // trim(lspec) // 'with lines'
- else
- pltstring='splot ' // datablock // ' notitle '//trim(lspec) // 'with lines'
- end if
- else
- pltstring='splot ' // datablock // ' notitle with lines'
- end if
-
- write ( this%file_unit, '(a)' ) trim(pltstring)
-
-
- !> Rev 0.2: animation
- ! if there is no animation finalize
- if (.not. (this%hasanimation)) then
- call finalize_plot(this)
- else
- write(this%file_unit, '(a, I2)') 'pause ', this%pause_seconds
- end if
-
- !: End of lplot3d
- end subroutine lplot3d
-
- subroutine function_plot(this, func,xrange,np)
- !..............................................................................
- ! fplot, plot a function in the range xrange=[xmin, xamx] with np points
- ! if np is not sent, then np=50 is assumed!
- ! func is the name of function to be plotted
- !..............................................................................
-
- class(gpf):: this
- interface
- function func(x)
- import :: wp
- real(wp), intent(in) :: x
- real(wp) :: func
- end function func
- end interface
- real(wp), intent(in) :: xrange(2)
- integer, optional, intent(in):: np
-
- integer:: n
- integer:: i
- integer:: alloc_err
- real(wp), allocatable :: x(:)
- real(wp), allocatable :: y(:)
-
- if (present(np)) then
- n=np
- else
- n=50
- end if
- allocate(x(1:n), y(1:n), stat=alloc_err)
- if (alloc_err /=0) then
- stop "Allocation error in fplot procedure..."
- end if
- !Create set of xy data
- x=linspace(xrange(1),xrange(2), n)
- y=[ (func(x(i)), i=1, n) ]
-
- call plot2d_vector_vs_vector(this,x,y)
-
- ! cleanup memory
- if (allocated(x)) deallocate(x)
- if (allocated(y)) deallocate(y)
-
-
- end subroutine function_plot
-
-
- subroutine semilogxv(this, x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4, axes4 )
- !..............................................................................
- ! This procedure is the same as plotXY with logarithmic x1 and x2 axes
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x1(:) ! vector of data for x
- real(wp), intent(in), optional :: y1(:) ! vector of data for y
- character(len=*), intent(in), optional :: ls1 ! line specification
- character(len=*), intent(in), optional :: axes1
-
- real(wp), intent(in), dimension(:), optional :: x2
- real(wp), intent(in), dimension(:), optional :: y2
- character(len=*), intent(in), optional :: ls2
- character(len=*), intent(in), optional :: axes2
-
- real(wp), intent(in), dimension(:), optional :: x3
- real(wp), intent(in), dimension(:), optional :: y3
- character(len=*), intent(in), optional :: ls3
- character(len=*), intent(in), optional :: axes3
-
- real(wp), intent(in), dimension(:), optional :: x4
- real(wp), intent(in), dimension(:), optional :: y4
- character(len=*), intent(in), optional :: ls4
- character(len=*), intent(in), optional :: axes4
- this%plotscale='semilogx'
- call plot2d_vector_vs_vector(this, &
- x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4, axes4 )
- ! Set the plot scale as linear. It means log scale is off
- this%plotscale='linear'
-
- end subroutine semilogxv
-
-
- !..............................................................................
- subroutine semilogyv(this, x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4,axes4 )
- !..............................................................................
- ! This procedure is the same as plotXY with logarithmic y1 and y2 axes
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x1(:) ! vector of data for x
- real(wp), intent(in), optional :: y1(:) ! vector of data for y
- character(len=*), intent(in), optional :: ls1 ! line specification
- character(len=*), intent(in), optional :: axes1
-
- real(wp), intent(in), dimension(:), optional :: x2
- real(wp), intent(in), dimension(:), optional :: y2
- character(len=*), intent(in), optional :: ls2
- character(len=*), intent(in), optional :: axes2
-
- real(wp), intent(in), dimension(:), optional :: x3
- real(wp), intent(in), dimension(:), optional :: y3
- character(len=*), intent(in), optional :: ls3
- character(len=*), intent(in), optional :: axes3
-
- real(wp), intent(in), dimension(:), optional :: x4
- real(wp), intent(in), dimension(:), optional :: y4
- character(len=*), intent(in), optional :: ls4
- character(len=*), intent(in), optional :: axes4
-
- this%plotscale='semilogy'
- call plot2d_vector_vs_vector(this, &
- x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4, axes4 )
- ! Set the plot scale as linear. It means log scale is off
- this%plotscale='linear'
-
-
- end subroutine semilogyv
-
-
-
- subroutine loglogv(this, x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4, axes4 )
- !..............................................................................
- ! This procedure is the same as plotXY with logarithmic x1, y1, x2, y2 axes
- !..............................................................................
-
- class(gpf):: this
- ! Input vector
- real(wp), intent(in) :: x1(:) ! vector of data for x
- real(wp), intent(in), optional :: y1(:) ! vector of data for y
- character(len=*), intent(in), optional :: ls1 ! line specification
- character(len=*), intent(in), optional :: axes1
-
- real(wp), intent(in), dimension(:), optional :: x2
- real(wp), intent(in), dimension(:), optional :: y2
- character(len=*), intent(in), optional :: ls2
- character(len=*), intent(in), optional :: axes2
-
- real(wp), intent(in), dimension(:), optional :: x3
- real(wp), intent(in), dimension(:), optional :: y3
- character(len=*), intent(in), optional :: ls3
- character(len=*), intent(in), optional :: axes3
-
- real(wp), intent(in), dimension(:), optional :: x4
- real(wp), intent(in), dimension(:), optional :: y4
- character(len=*), intent(in), optional :: ls4
- character(len=*), intent(in), optional :: axes4
-
-
- this%plotscale='loglog'
- call plot2d_vector_vs_vector(this, &
- x1, y1, ls1, axes1, &
- x2, y2, ls2, axes2, &
- x3, y3, ls3, axes3, &
- x4, y4, ls4, axes4 )
- ! Set the plot scale as linear. It means log scale is off
- this%plotscale='linear'
-
- end subroutine loglogv
-
-
-
- subroutine semilogxm(this, xv, ymat, lspec)
- !..............................................................................
- !Plots a matrix against a vector with logarithmic x-axis
- !For more information see plot2D_matrix_vs_vector procedure
- !Everything is the same except the x-axis scale
- !..............................................................................
-
- implicit none
- class(gpf) :: this
- ! Input arrays
- real(wp), intent(in) :: xv(:)
- real(wp), intent(in) :: ymat(:,:)
- character(len=*), intent(in), optional :: lspec
-
- this%plotscale='semilogx'
- call plot2d_matrix_vs_vector(this, xv,ymat, lspec)
- ! Set the plot scale as linear. It means log scale is off
- this%plotscale='linear'
-
-
- end subroutine semilogxm
-
-
-
- subroutine semilogym(this, xv,ymat, lspec)
- !..............................................................................
- !Plots a matrix against a vector with logarithmic y-axis
- !For more information see plot2D_matrix_vs_vector procedure
- !Everything is the same except the x-axis scale
- !..............................................................................
-
- implicit none
- class(gpf) :: this
- ! Input arrays
- real(wp), intent(in) :: xv(:)
- real(wp), intent(in) :: ymat(:,:)
- character(len=*), intent(in), optional :: lspec
-
- this%plotscale='semilogy'
- call plot2d_matrix_vs_vector(this, xv,ymat, lspec)
- ! Set the plot scale as linear. It means log scale is off
- this%plotscale='linear'
-
-
- end subroutine semilogym
-
-
- subroutine loglogm(this, xv,ymat, lspec)
- !..............................................................................
- !Plots a matrix against a vector with logarithmic x-axis and y-axis
- !For more information see plot2D_matrix_vs_vector procedure
- !Everything is the same except the axes scale
- !..............................................................................
-
- implicit none
- class(gpf) :: this
- ! Input arrays
- real(wp), intent(in) :: xv(:)
- real(wp), intent(in) :: ymat(:,:)
- character(len=*), intent(in), optional :: lspec
-
- this%plotscale='loglog'
- call plot2d_matrix_vs_vector(this, xv,ymat, lspec)
- ! Set the plot scale as linear. It means log scale is off
- this%plotscale='linear'
-
-
- end subroutine loglogm
-
-
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section Three: Animation Routines
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
- subroutine sub_animation_start(this, pause_seconds)
- !-------------------------------------------------------------------------------
- ! sub_animation_start: set the setting to start an animation
- ! it simply set flags and open a script file to write data
- !-------------------------------------------------------------------------------
- class(gpf) :: this
- integer, intent(in), optional :: pause_seconds
-
-
- ! ogpf does not support multiplot with animation at the same time
- if (this%hasmultiplot) then
- print*, md_name // ': does not support animation in multiplot mode!'
- stop
- end if
-
-
- if (present(pause_seconds)) then
- this%pause_seconds = pause_seconds
- else
- this%pause_seconds = 2 ! delay in second
- end if
-
- this%frame_number = 0
-
- ! create the ouput file for writting gnuplot script
- call create_outputfile(this)
- this%hasfileopen = .true.
- this%hasanimation = .true.
-
- end subroutine sub_animation_start
-
-
- subroutine sub_animation_show(this)
- !-------------------------------------------------------------------------------
- ! sub_animation_show: simply resets the animation flags
- ! and finalize the plotting.
- !-------------------------------------------------------------------------------
-
- class(gpf) :: this
-
- this%frame_number = 0
- this%hasanimation = .false.
-
- call finalize_plot(this)
-
- end subroutine sub_animation_show
-
-
-
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section Four: Gnuplot direct scriptting
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
- subroutine addscript(this,strcmd)
- !..............................................................................
- ! addscript: accepts all type of gnuplot command as a string and store it
- ! in global txtscript to be later sent to gnuplot
- !..............................................................................
-
- class(gpf) :: this
- character(len=*), intent(in) :: strcmd
-
- if (.not.allocated(this%txtscript)) this%txtscript=''
- if (len_trim(this%txtscript) == 0 ) then
- this%txtscript = '' ! initialize string
- end if
- if ( len_trim(strcmd)>0 ) then
- this%txtscript = this%txtscript // splitstr(strcmd)
- end if
-
- end subroutine addscript
-
-
-
- subroutine runscript(this)
- !..............................................................................
- ! runscript sends the the script string (txtstring) into a script
- ! file to be run by gnuplot
- !..............................................................................
-
- class(gpf):: this
-
- !REV 0.18: a dedicated subroutine is used to create the output file
- call create_outputfile(this)
-
- !write the script
- call processcmd(this)
- write(unit=this%file_unit, fmt='(a)') this%txtscript
-
- ! close the file and call gnuplot
- call finalize_plot(this)
-
- end subroutine runscript
-
-
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section Five: gnuplot command processing and data writing to script file
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
- subroutine process_axes_set(axes_set, axes)
- !..............................................................................
- ! process_axesspec accepts the axes set and interpret it into
- ! a format to be sent to gnuplot.
- ! the axes set can be one of the following set
- ! x1y1, x1y2, x2y1, x2y2
- !..............................................................................
-
- character(len=*), intent(in) :: axes_set
- character(len=4), intent(out) :: axes
-
-
- if (len_trim (adjustl(axes_set)) == 0) then
- axes=''
- return
- end if
-
- select case ( lcase(trim (adjustl (axes_set) ) ) )
- case ('x1y1')
- axes='x1y1'
- case ('x1y2')
- axes='x1y2'
- case ('x2y1')
- axes='x2y1'
- case ('x2y2')
- axes='x2y2'
- case default ! wrong strings
- print*, md_name // ':process_axes_set:' // ' wrong axes set is sent.'// new_line(' ') &
- // 'axes set can be on of: x1y1, x1y2, x2y1, x2y2'
- axes=''
- return
- end select
-
- end subroutine process_axes_set
-
-
-
- subroutine process_linespec(order, lsstring, lspec, axes_set)
- !..............................................................................
- ! process_linespec accepts the line specification and interpret it into
- ! a format to be sent to gnuplot
- !..............................................................................
-
- integer, intent(in) :: order !1 for the first data series
- character(len=*), intent(out) :: lsstring
- character(len=*), intent(in), optional :: lspec
- character(len=*), intent(in), optional :: axes_set
-
- !local variables
- character(len=4) :: axes
- character(len=10) :: axes_setting
-
- !check the axes set
- axes_setting = ''
- if ( present (axes_set)) then
- call process_axes_set(axes_set, axes)
- if (len(trim(axes))> 0 ) then
- axes_setting = ' axes ' // axes
- end if
- end if
-
- select case(order)
- case(1)
- if ( present(lspec) ) then
- if (hastitle(lspec)) then
- lsstring='plot "-" '//trim(lspec) // axes_setting
- else
- lsstring='plot "-" notitle '//trim(lspec) // axes_setting
- end if
- else
- lsstring='plot "-" notitle' // axes_setting
- end if
- case default !e.g. 2, 3, 4, ...
- if (present(lspec)) then
- if (hastitle(lspec)) then
- lsstring=', "-" '// trim(lspec) // axes_setting
- else
- lsstring=', "-" notitle '// trim(lspec) // axes_setting
- end if
- else
- lsstring=', "-" notitle' // axes_setting
- end if
- end select
- end subroutine process_linespec
-
-
-
- subroutine processcmd(this)
- !..............................................................................
- ! This subroutine writes all the data into plot file
- ! to be read by gnuplot
- !..............................................................................
-
- class(gpf) :: this
-
- ! write the plot style for data
- ! this is used only when 3D plots (splot, cplot) is used
- if (allocated(this%txtdatastyle)) then
- write ( this%file_unit, '("set style data ", a)' ) this%txtdatastyle
- write ( this%file_unit, '(a)' )
- end if
-
-
- ! Write options
- if ( this%hasoptions ) then
- write ( this%file_unit, '(" ")' )
- write ( this%file_unit, '("# options")' )
- write ( this%file_unit, '(a)' ) this%txtoptions
- write ( this%file_unit, '(a)' )
- end if
-
- ! Check with plot scale: i.e linear, logx, logy, or log xy
- write( this%file_unit, '(" ")' )
- write( this%file_unit, '("# plot scale")' )
- select case (this%plotscale)
- case ('semilogx')
- write ( this%file_unit, '("set logscale x")' )
- case ('semilogy')
- write ( this%file_unit, '("set logscale y")' )
- case ('loglog')
- write ( this%file_unit, '("set logscale xy")' )
- case default !for no setting
- !pass
- end select
-
- !!>0.22
- ! write annotation
- write ( this%file_unit, '(" ")' )
- write ( this%file_unit, '("# Annotation: title and labels")' )
- call write_label(this, 'plot_title')
- call write_label(this, 'xlabel' )
- call write_label(this, 'x2label' )
- call write_label(this, 'ylabel' )
- call write_label(this, 'y2label' )
- call write_label(this, 'zlabel' )
-
- ! axes range
- write ( this%file_unit, '(" ")')
- write ( this%file_unit, '("# axes setting")')
- if (this%hasxrange) then
- write ( this%file_unit, '("set xrange [",G0,":",G0,"]")' ) this%xrange
- end if
- if (this%hasyrange) then
- write ( this%file_unit, '("set yrange [",G0,":",G0,"]")' ) this%yrange
- end if
- if (this%haszrange) then
- write ( this%file_unit, '("set zrange [",G0,":",G0,"]")' ) this%zrange
- end if
-
- ! secondary axes range
- if (this%hasx2range) then
- write ( this%file_unit, '("set x2range [",G0,":",G0,"]")' ) this%x2range
- end if
- if (this%hasy2range) then
- write ( this%file_unit, '("set y2range [",G0,":",G0,"]")' ) this%y2range
- end if
- ! finish by new line
- write ( this%file_unit, '(a)' ) ! emptyline
-
- end subroutine processcmd
-
-
-
- subroutine write_label(this, lblname)
- !..............................................................................
- ! This subroutine writes the labels into plot file
- ! to be read by gnuplot
- !..............................................................................
-
-
- ! write_label
- class(gpf) :: this
- character(len=*) :: lblname
-
- ! local var
- character(len=:), allocatable :: lblstring
- character(len=:), allocatable :: lblset
- type(tplabel) :: label
-
- select case (lblname)
- case ('xlabel')
- if (.not. (this%tpxlabel%has_label) ) then
- return ! there is no label
- end if
- lblset = 'set xlabel "'
- label = this%tpxlabel
- case ('x2label')
- if (.not. (this%tpx2label%has_label) ) then
- return ! there is no label
- end if
- lblset = 'set x2label "'
- label = this%tpx2label
- case ('ylabel')
- if (.not. (this%tpylabel%has_label) ) then
- return ! there is no label
- end if
- lblset = 'set ylabel "'
- label = this%tpylabel
- case ('y2label')
- if (.not. (this%tpy2label%has_label) ) then
- return ! there is no label
- end if
- lblset = 'set y2label "'
- label = this%tpy2label
- case ('zlabel')
- if (.not. (this%tpzlabel%has_label) ) then
- return ! there is no label
- end if
- lblset = 'set zlabel "'
- label = this%tpzlabel
- case ('plot_title')
- if (.not. (this%tpplottitle%has_label) ) then
- return ! there is no label
- end if
- lblset = 'set title "'
- label = this%tpplottitle
- end select
-
- lblstring = ''
- ! if there is a label continue to set it
- lblstring = lblstring // lblset // trim(label%lbltext)//'"'
- if (allocated(label%lblcolor)) then
- lblstring = lblstring // ' tc "' //trim(label%lblcolor) // '"'
- end if
- ! set font and size
- if (allocated(this%tpxlabel%lblfontname)) then
- lblstring = lblstring // ' font "'// trim(label%lblfontname) // ','
- if (label%lblfontsize /= NOT_INITIALIZED) then
- lblstring = lblstring // num2str(label%lblfontsize) //'"'
- else
- lblstring = lblstring //'"'
- end if
- else ! check if only font size has been given
- if (label%lblfontsize /= NOT_INITIALIZED ) then
- lblstring = lblstring // ' font ",' // num2str(label%lblfontsize) //'"'
- end if
- end if
- ! set rotation
- if (label%lblrotate /= NOT_INITIALIZED ) then
- lblstring = lblstring // ' rotate by ' // num2str(label%lblrotate )
- end if
-
-
- ! write to ogpf script file
- write ( this%file_unit, '(a)' ) lblstring
-
-
- end subroutine write_label
-
-
-
- function color_palettes(palette_name) result(str)
- !...............................................................................
- ! color_palettes create color palette as a
- ! string to be written into gnuplot script file
- ! the palettes credit goes to: Anna Schnider (https://github.com/aschn) and
- ! Hagen Wierstorf (https://github.com/hagenw)
- !...............................................................................
- character(len=*), intent(in) :: palette_name
- character(len=:), allocatable :: str
-
- ! local variables
- character(len=1) :: strnumber
- character(len=11) :: strblank
- integer :: j
- integer :: maxcolors
-
- ! define the color palettes
- character(len=:), allocatable :: pltname
- character(len=7) :: palette(9) ! palettes with maximum 9 colors
-
- maxcolors = 8 ! default number of discrete colors
- palette=''
- select case ( lcase(trim(adjustl(palette_name))) )
- case ('set1')
- pltname='set1'
- palette(1:maxcolors)=[&
- "#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", &
- "#FF7F00", "#FFFF33", "#A65628", "#F781BF" ]
- case ('set2')
- pltname='set2'
- palette(1:maxcolors)=[&
- "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", &
- "#A6D854", "#FFD92F", "#E5C494", "#B3B3B3" ]
- case ('set3')
- pltname='set3'
- palette(1:maxcolors)=[&
- "#8DD3C7", "#FFFFB3", "#BEBADA", "#FB8072", &
- "#80B1D3", "#FDB462", "#B3DE69", "#FCCDE5" ]
- case ('palette1')
- pltname='palette1'
- palette(1:maxcolors)=[&
- "#FBB4AE", "#B3CDE3", "#CCEBC5", "#DECBE4", &
- "#FED9A6", "#FFFFCC", "#E5D8BD", "#FDDAEC" ]
- case ('palette2')
- pltname='palette2'
- palette(1:maxcolors)=[&
- "#B3E2CD", "#FDCDAC", "#CDB5E8", "#F4CAE4", &
- "#D6F5C9", "#FFF2AE", "#F1E2CC", "#CCCCCC" ]
- case ('paired')
- pltname='paired'
- palette(1:maxcolors)=[&
- "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", &
- "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00" ]
- case ('dark2')
- pltname='dark2'
- palette(1:maxcolors)=[&
- "#1B9E77", "#D95F02", "#7570B3", "#E7298A", &
- "#66A61E", "#E6AB02", "#A6761D", "#666666" ]
- case ('accent')
- pltname='accent'
- palette(1:maxcolors)=[&
- "#7FC97F", "#BEAED4", "#FDC086", "#FFFF99", &
- "#386CB0", "#F0027F", "#BF5B17", "#666666" ]
- case ('jet')
- ! Matlab jet palette
- maxcolors = 9
- pltname='jet'
- palette(1:maxcolors)=[&
- '#000090', '#000fff', '#0090ff', '#0fffee', &
- '#90ff70', '#ffee00', '#ff7000', '#ee0000', '#7f0000' ]
- case default
- print*, md_name // ": color_palettes: wrong palette name"
- print*, 'gnuplot default palette will be used!'
- str=' ' ! empty palette is returned!
- return
- end select
-
- ! generate the gnuplot palette as a single multiline string
- str = '# Define the ' // pltname // ' pallete' // new_line(' ')
- str = str // 'set palette defined ( \' // new_line(' ')
- strblank = ' ' ! pad certain number of paces
- do j=1, maxcolors - 1
- write(unit =strnumber, fmt='(I1)' ) j-1
- str = str // strblank // strnumber // ' "' // palette(j) // '",\' // new_line(' ')
- end do
-
- j =maxcolors
- write(strnumber, fmt='(I1)') j
- str = str // strblank // strnumber // ' "' // palette(j) // '" )' // new_line(' ')
-
- end function color_palettes
-
-
-
- subroutine write_xydata(file_unit,ndata,x,y)
- !..............................................................................
- ! Writes set of xy data into a file
- !..............................................................................
-
- integer, intent(in) :: file_unit
- integer, intent(in) :: ndata
- real(wp), intent(in) :: x(:)
- real(wp), intent(in), optional :: y(:)
-
- integer:: i
-
- ! TODO (Mohammad#1#12/22/17): The format string shall be modified to write the
- ! number in more suitable form
- ! Rev 0.18
- if (present(y) ) then !both x and y are present, data are xy set
- do i = 1, ndata
- write ( file_unit, * ) x(i), y(i)
- end do
- else !only x is passed, data are index-x set
- do i = 1, ndata
- write ( file_unit, * ) x(i)
- end do
- end if
- write ( file_unit, '(a)' ) 'e' !end of set of data
-
- end subroutine write_xydata
-
-
-
- subroutine create_outputfile(this)
- !..............................................................................
- ! Create an output file, assign a file_unit
- ! for writing the gnuplot commands
- !..............................................................................
-
- ! Rev 0.18
- class(gpf), intent(INOUT ) :: this
-
- if (this%hasfileopen) then
- ! there is nothing to do, file has been already open!
- return
- end if
-
- !> Rev 0.2 animation
-
- ! animation handling
- if (this%hasanimation ) then
- this%frame_number = this%frame_number + 1 ! for future use
- end if
-
- ! Open the output file
-
- if (.not. (this%hasfilename)) then ! check if no file has been set by user
- this%txtfilename=gnuplot_output_filename
- end if
-
- open ( newunit = this%file_unit, file = this%txtfilename, status = 'replace', iostat = this%status )
-
-
- if (this%status /= 0 ) then
- print*, "md_helperproc, create_outputfile: cannot open file for output"
- stop
- end if
-
-
- ! Set the gnuplot terminal, write ogpf configuration (customized setting)
- ! Can be overwritten by options
-
- ! write signature
- write ( this%file_unit, '(a)' ) '# ' // md_name
- write ( this%file_unit, '(a)' ) '# ' // md_rev
- write ( this%file_unit, '(a)' ) '# ' // md_lic
- write ( this%file_unit, '(a)' ) ! emptyline
-
- ! write the global settings
- write ( this%file_unit, '(a)' ) '# gnuplot global setting'
- write(unit=this%file_unit, fmt='(a)') 'set term ' // gnuplot_term_type // &
- ' size ' // gnuplot_term_size // ' enhanced font "' // &
- gnuplot_term_font // '"' // &
- ' title "' // md_name // ': ' // md_rev //'"' ! library name and version
-
- ! write the preset configuration for gnuplot (ogpf customized settings)
- if (this%preset_configuration) then
- call this%preset_gnuplot_config()
- end if
- ! write multiplot setting
- if (this%hasmultiplot) then
- write(this%file_unit, fmt='(a, I2, a, I2)') 'set multiplot layout ', &
- this%multiplot_rows, ',', this%multiplot_cols
- end if
- ! set flag true for file is opened
- this%hasfileopen = .true.
-
- end subroutine create_outputfile
-
-
- subroutine preset_gnuplot_config(this)
- !..............................................................................
- ! To write the preset configuration for gnuplot (ogpf customized settings)
- !..............................................................................
- class(gpf) :: this
-
- write(this%file_unit, fmt='(a)')
- write(this%file_unit, fmt='(a)') '# ogpf extra configuration'
- write(this%file_unit, fmt='(a)') '# -------------------------------------------'
-
-
- ! color definition
- write(this%file_unit, fmt='(a)') '# color definitions'
- write(this%file_unit, fmt='(a)') 'set style line 1 lc rgb "#800000" lt 1 lw 2'
- write(this%file_unit, fmt='(a)') 'set style line 2 lc rgb "#ff0000" lt 1 lw 2'
- write(this%file_unit, fmt='(a)') 'set style line 3 lc rgb "#ff4500" lt 1 lw 2'
- write(this%file_unit, fmt='(a)') 'set style line 4 lc rgb "#ffa500" lt 1 lw 2'
- write(this%file_unit, fmt='(a)') 'set style line 5 lc rgb "#006400" lt 1 lw 2'
- write(this%file_unit, fmt='(a)') 'set style line 6 lc rgb "#0000ff" lt 1 lw 2'
- write(this%file_unit, fmt='(a)') 'set style line 7 lc rgb "#9400d3" lt 1 lw 2'
- write(this%file_unit, fmt='(a)')
- ! axes setting
- write(this%file_unit, fmt='(a)') '# Axes'
- write(this%file_unit, fmt='(a)') 'set border linewidth 1.15'
- write(this%file_unit, fmt='(a)') 'set tics nomirror'
- write(this%file_unit, fmt='(a)')
-
- write(this%file_unit, fmt='(a)') '# grid'
- write(this%file_unit, fmt='(a)') '# Add light grid to plot'
- write(this%file_unit, fmt='(a)') 'set style line 102 lc rgb "#d6d7d9" lt 0 lw 1'
- write(this%file_unit, fmt='(a)') 'set grid back ls 102'
- write(this%file_unit, fmt='(a)')
- ! set the plot style
- write(this%file_unit, fmt='(a)') '# plot style'
- write(this%file_unit, fmt='(a)') 'set style data linespoints'
- write(this%file_unit, fmt='(a)')
-
- write(this%file_unit, fmt='(a)') '# -------------------------------------------'
- write(this%file_unit, fmt='(a)') ''
-
-
- end subroutine preset_gnuplot_config
-
-
-
- subroutine finalize_plot(this)
- !..............................................................................
- ! To finalize the writing of gnuplot commands/data and close the output file.
- !..............................................................................
- class(gpf) :: this
-
- ! check for multiplots
- if (this%hasmultiplot) then
- if (this%multiplot_total_plots < this%multiplot_rows * this%multiplot_cols - 1 ) then
- ! increment the number of plots
- this%multiplot_total_plots = this%multiplot_total_plots + 1
- return ! do not finalize plot, still there is places in multiplot
- else
- ! close multiplot
- write(this%file_unit, fmt='(a)') 'unset multiplot'
- ! reset multiplot flag
- this%hasmultiplot = .false.
-
- end if
- end if
-
- close ( unit = this%file_unit ) ! close the script file
- this%hasfileopen = .false. ! reset file open flag
- this%hasanimation = .false.
- ! Use shell command to run gnuplot
- if (get_os_type() == 1) then
- call execute_command_line ('wgnuplot -persist ' // this%txtfilename) ! Now plot the results
- else
- call execute_command_line ('gnuplot -persist ' // this%txtfilename) ! Now plot the results
- end if
- contains
- integer function get_os_type() result(r)
- !! Returns one of OS_WINDOWS, others
- !! At first, the environment variable `OS` is checked, which is usually
- !! found on Windows.
- !! Copy from fpm/fpm_environment: https://github.com/fortran-lang/fpm/blob/master/src/fpm_environment.F90
- character(len=32) :: val
- integer :: length, rc
-
- integer, parameter :: OS_OTHERS = 0
- integer, parameter :: OS_WINDOWS = 1
-
- r = OS_OTHERS
- ! Check environment variable `OS`.
- call get_environment_variable('OS', val, length, rc)
-
- if (rc == 0 .and. length > 0 .and. index(val, 'Windows_NT') > 0) then
- r = OS_WINDOWS
- return
- end if
-
- end function
-
- end subroutine finalize_plot
-
-
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section Six: Utility and helper procedures
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
- function hastitle(string)
- !..............................................................................
- ! check to see if the plot title (used as legend = key)
- !..............................................................................
-
- character(len=*), intent(in) :: string
- logical:: hastitle
- integer:: idx1
- integer:: idx2
-
- idx1=index( lcase(string),'title') !Check if title is passed
- idx2=index(' ' // lcase(string),' t ') !Check if the abbreviated title 't' is passed. Extra space is added
- ! at the beginning of string to find starting 't'
- if (idx1 /=0 .or. idx2 /=0 ) then
- hastitle=.true.
- else
- hastitle=.false.
- end if
-
- end function hastitle
-
-
- function checkdim(nx,ny)
- !..............................................................................
- ! checkdim checks the equality of dimensions of two vector
- !..............................................................................
-
- integer, intent(in):: nx
- integer, intent(in):: ny
- logical:: checkdim
- if (nx/=ny) then
- checkdim=.false.
- else
- checkdim=.true.
- end if
-
- end function checkdim
-
-
-
- !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !> Section Seven: String utility Routines
- !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
-
- pure function splitstr(str) result(spstr)
- !..............................................................................
- !splitstr, separate a string using ";" delimiters
- !..............................................................................
-
- character(len=*), intent(in) :: str
-
- ! local variables
- character, parameter :: delimiter=';'
- character(len=:), allocatable :: spstr
- integer :: n
- integer :: m
- integer :: k
-
-
- k=len_trim(str) !length with removed trailing blanks
- n=scan(str,delimiter)
- if (n==0) then ! This is a single statement
- spstr = adjustl(str) // new_line(' ')
- return
- end if
-
- ! for two or more statements separated by ;
- spstr = ''
- m=1
- do while (n/=0 .and. m=65 .and. n <= 90) then
- lcase(i:i)=char(n+32)
- else
- lcase(i:i)=chr
- end if
- end do
- end function lcase
-
-
- function num2str_i4(number_in)
- !..............................................................................
- ! num2str_int: converts integer number to string
- !..............................................................................
-
- integer(kind=kind(1)), intent(in) :: number_in
- character(len=:), allocatable :: num2str_i4
-
- ! local variable
- character(len=range(number_in)) :: strnm
- write(unit=strnm, fmt='(I0)') number_in
- num2str_i4 = trim(strnm)
-
- end function num2str_i4
-
- function num2str_r4(number_in, strfmt)
- !..............................................................................
- ! num2str_r4: converts single precision real number to string
- ! strfmt is the optional format string
- !..............................................................................
-
- real(kind=sp), intent(in) :: number_in
- character(len=*), intent(in), optional :: strfmt
- character(len=:), allocatable :: num2str_r4
-
- ! local variable
- character(len=range(number_in)) :: strnm
-
-
- if (present(strfmt)) then
- write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in
- else
- write(unit=strnm, fmt='(G0)') number_in
- end if
-
- num2str_r4 = trim(strnm)
-
- end function num2str_r4
-
-
- function num2str_r8(number_in, strfmt)
- !..............................................................................
- ! num2str_real: converts double precision real number to string
- ! strfmt is the optional format string
- !..............................................................................
-
- real(kind=dp), intent(in) :: number_in
- character(len=*), intent(in), optional :: strfmt
- character(len=:), allocatable :: num2str_r8
-
- ! local variable
- character(len=range(number_in)) :: strnm
-
- if (present(strfmt)) then
- write(unit=strnm, fmt= '('//trim(strfmt)//')' ) number_in
- else
- write(unit=strnm, fmt='(G0)') number_in
- end if
-
- num2str_r8 = trim(strnm)
-
- end function num2str_r8
-
-
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- !!> Section Eight: Math helper function
- !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
- function arange(xa, xb, dx)
- !..............................................................................
- ! returns a vector in the form of [xa, xa+dx, xa+2*dx, ...]
- ! the number of elements is calculated as m = n+ 1,
- ! where n= int ( (xa-xb)/dx) ).
- ! arange is similar to colon in Matlab and arange in Python!
- !
- ! NOTE:
- ! - If n calculated as zero, result is [xa]
- ! - If n calculated as Inf (dx=0), a fatal error will be raised
- ! - If n calculated as negative value (e.g xa 0.0 "
- stop
- end if
- else
- dxl = 1.0_wp
- end if
-
- if ( (xa < xb) .and. (dx < 0.0_wp) ) then
- print*, "arange procedure: Fatal Error: wrong dx, use a dx > 0.0 "
- stop
- end if
-
- n = int( (xb-xa)/ dxl) ! n+1 is the number of elements
-
- allocate(arange(n), stat=ierr)
-
- if (ierr /= 0) then
- print*, "arange procedure: Fatal Error, allocation failed in arange function"
- stop
- end if
-
- arange = [(xa + i*dxl, i=0, n)]
-
- end function arange
-
-
- function linspace(a,b,n_elements)
- !..............................................................................
- ! returns a linearly spaced vector with n points in [a, b]
- ! if n is omitted, 100 points will be considered
- !..............................................................................
-
- real(wp), intent(in) :: a
- real(wp), intent(in) :: b
- integer, intent(in), optional :: n_elements
- real(wp), allocatable :: linspace(:)
-
- ! Local vars
- real(wp) :: dx
- integer :: i
- integer :: n
- integer :: ierr
-
- if (present(n_elements)) then
- if (n_elements <=1 ) then
- print*, "linspace procedure: Error: wrong value of n_elements, use an n_elements > 1"
- stop
- end if
- n=n_elements
- else
- n=100
- end if
-
- allocate(linspace(n), stat=ierr)
- if (ierr /= 0) then
- print*, "linspace procedure: Fatal Error, Allocation failed in linspace function"
- stop
- end if
-
- dx=(b-a)/real((n-1),wp)
- linspace=[(i*dx+a, i=0,n-1)]
-
- end function linspace
-
-
-
- subroutine meshgrid(x,y,xgv,ygv, ierr)
- !..............................................................................
- !meshgrid generate mesh grid over a rectangular domain of [xmin xmax, ymin, ymax]
- ! Inputs:
- ! xgv, ygv are grid vectors in form of full grid data
- ! Outputs:
- ! X and Y are matrix each of size [ny by nx] contains the grid data.
- ! The coordinates of point (i,j) is [X(i,j), Y(i,j)]
- ! ierr: The error flag
- ! """
- ! # Example
- ! # call meshgrid(X, Y, [0.,1.,2.,3.],[5.,6.,7.,8.])
- ! # X
- ! # [0.0, 1.0, 2.0, 3.0,
- ! # 0.0, 1.0, 2.0, 3.0,
- ! # 0.0, 1.0, 2.0, 3.0,
- ! # 0.0, 1.0, 2.0, 3.0]
- ! #
- ! #Y
- ! #[ 5.0, 5.0, 5.0, 5.0,
- ! # 6.0, 6.0, 6.0, 6.0,
- ! # 7.0, 7.0, 7.0, 7.0,
- ! # 8.0, 8.0, 8.0, 8.0]
- !..............................................................................
- ! Rev 0.2, Feb 2018
- ! New feature added: xgv and ygv as full grid vector are accepted now
-
- ! Arguments
- real(wp), intent(out), allocatable :: x(:,:)
- real(wp), intent(out), allocatable :: y(:,:)
- real(wp), intent(in) :: xgv(:) ! x grid vector [start, stop, step] or [start, stop]
- real(wp), intent(in), optional :: ygv(:) ! y grid vector [start, stop, step] or [start, stop]
- integer, intent(out), optional :: ierr ! the error value
-
- ! Local variables
- integer:: sv
- integer:: nx
- integer:: ny
- logical:: only_xgv_available
-
- ! Initial setting
- only_xgv_available = .false.
- sv=0 !Assume no error
-
- nx=size(xgv, dim=1)
-
- if (present(ygv)) then
- ny = size(ygv, dim=1)
- else
- only_xgv_available=.true.
- ny=nx
- end if
-
- allocate(x(ny,nx),y(ny,nx),stat=sv)
- if (sv /=0) then
- print*, "allocataion erro in meshgrid"
- stop
- end if
-
- x(1,:) = xgv
- x(2:ny,:) = spread(xgv, dim=1, ncopies=ny-1)
-
- if (only_xgv_available) then
- y=transpose(x)
- else
- y(:,1) = ygv
- y(:,2:nx) = spread(ygv,dim=2,ncopies=nx-1)
- end if
-
- if (present(ierr)) then
- ierr=sv
- end if
-
- end subroutine meshgrid
-
-
- !End of ogpf
-end module ogpf
diff --git a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90
index 37c0ded01..cd3af48cd 100644
--- a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90
+++ b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90
@@ -17,12 +17,12 @@
MODULE IntVector_ConstructorMethod
USE BaseType, ONLY: IntVector_
USE GlobalData, ONLY: I4B, DFP, LGT, INT8, INT16, INT32, INT64, &
-& REAL64, REAL32
+ REAL64, REAL32
PRIVATE
PUBLIC :: Shape
PUBLIC :: SIZE
-PUBLIC :: getTotalDimension
+PUBLIC :: GetTotalDimension
PUBLIC :: ALLOCATE
PUBLIC :: DEALLOCATE
PUBLIC :: Reallocate
diff --git a/src/modules/IntVector/src/IntVector_GetMethod.F90 b/src/modules/IntVector/src/IntVector_GetMethod.F90
index f04c4768c..866b6248a 100644
--- a/src/modules/IntVector/src/IntVector_GetMethod.F90
+++ b/src/modules/IntVector/src/IntVector_GetMethod.F90
@@ -18,6 +18,7 @@
MODULE IntVector_GetMethod
USE GlobalData, ONLY: DFP, I4B, LGT, INT8, INT16, INT32, INT64
USE BaseType, ONLY: IntVector_
+
PRIVATE
PUBLIC :: GET
@@ -34,10 +35,10 @@ MODULE IntVector_GetMethod
! summary: Returns IntVector instance
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_1(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_1(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- TYPE(IntVector_), INTENT(IN) :: DataType
- TYPE(IntVector_) :: Val
+ TYPE(IntVector_), INTENT(IN) :: datatype
+ TYPE(IntVector_) :: val
END FUNCTION intVec_get_1
END INTERFACE Get
@@ -51,12 +52,12 @@ END FUNCTION intVec_get_1
! summary: Returns an instance of [[intvector_]], obj(indx)
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_2(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_2(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- TYPE(IntVector_), INTENT(IN) :: DataType
+ TYPE(IntVector_), INTENT(IN) :: datatype
INTEGER(I4B), INTENT(IN) :: Indx(:)
- TYPE(IntVector_) :: Val
+ TYPE(IntVector_) :: val
END FUNCTION intVec_get_2
END INTERFACE Get
@@ -71,16 +72,16 @@ END FUNCTION intVec_get_2
INTERFACE Get
MODULE PURE FUNCTION intVec_get_3(obj, istart, iend, &
- & stride, DataType) RESULT(Val)
+ & stride, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- TYPE(IntVector_), INTENT(IN) :: DataType
+ TYPE(IntVector_), INTENT(IN) :: datatype
!! an instance of [[IntVector_]]
INTEGER(I4B), INTENT(IN) :: istart
!! starting index value
INTEGER(I4B), OPTIONAL, INTENT(IN) :: iend, stride
!! iend is optional, default value is size(obj)
!! stride is optional, default value is 1.
- TYPE(IntVector_) :: Val
+ TYPE(IntVector_) :: val
!! returned value
END FUNCTION intVec_get_3
END INTERFACE Get
@@ -105,10 +106,10 @@ END FUNCTION intVec_get_3
! The size of val is size(obj(1)) + size(obj(2)) + ...
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_4(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_4(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- TYPE(IntVector_), INTENT(IN) :: DataType
- TYPE(IntVector_) :: Val
+ TYPE(IntVector_), INTENT(IN) :: datatype
+ TYPE(IntVector_) :: val
END FUNCTION intVec_get_4
END INTERFACE Get
@@ -122,12 +123,12 @@ END FUNCTION intVec_get_4
! summary: Serialized the vector of [[IntVector_]], select values by indx
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_5(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_5(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- TYPE(IntVector_), INTENT(IN) :: DataType
+ TYPE(IntVector_), INTENT(IN) :: datatype
INTEGER(I4B), INTENT(IN) :: Indx(:)
- TYPE(IntVector_) :: Val
+ TYPE(IntVector_) :: val
END FUNCTION intVec_get_5
END INTERFACE Get
@@ -137,11 +138,11 @@ END FUNCTION intVec_get_5
INTERFACE Get
MODULE PURE FUNCTION intVec_get_6(obj, iStart, iEnd, &
- & Stride, DataType) RESULT(Val)
+ & Stride, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- TYPE(IntVector_), INTENT(IN) :: DataType
- TYPE(IntVector_) :: Val
+ TYPE(IntVector_), INTENT(IN) :: datatype
+ TYPE(IntVector_) :: val
END FUNCTION intVec_get_6
END INTERFACE Get
@@ -150,25 +151,25 @@ END FUNCTION intVec_get_6
!----------------------------------------------------------------------------
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_7a(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_7a(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(INT8), INTENT(IN) :: DataType
- INTEGER(INT8), ALLOCATABLE :: Val(:)
+ INTEGER(INT8), INTENT(IN) :: datatype
+ INTEGER(INT8), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_7a
- MODULE PURE FUNCTION intVec_get_7b(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_7b(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(INT16), INTENT(IN) :: DataType
- INTEGER(INT16), ALLOCATABLE :: Val(:)
+ INTEGER(INT16), INTENT(IN) :: datatype
+ INTEGER(INT16), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_7b
- MODULE PURE FUNCTION intVec_get_7c(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_7c(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(INT32), INTENT(IN) :: DataType
- INTEGER(INT32), ALLOCATABLE :: Val(:)
+ INTEGER(INT32), INTENT(IN) :: datatype
+ INTEGER(INT32), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_7c
- MODULE PURE FUNCTION intVec_get_7d(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_7d(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(INT64), INTENT(IN) :: DataType
- INTEGER(INT64), ALLOCATABLE :: Val(:)
+ INTEGER(INT64), INTENT(IN) :: datatype
+ INTEGER(INT64), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_7d
END INTERFACE Get
@@ -177,33 +178,33 @@ END FUNCTION intVec_get_7d
!----------------------------------------------------------------------------
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_8a(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_8a(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT8), INTENT(IN) :: DataType
- INTEGER(INT8), ALLOCATABLE :: Val(:)
+ INTEGER(INT8), INTENT(IN) :: datatype
+ INTEGER(INT8), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_8a
- MODULE PURE FUNCTION intVec_get_8b(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_8b(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT16), INTENT(IN) :: DataType
- INTEGER(INT16), ALLOCATABLE :: Val(:)
+ INTEGER(INT16), INTENT(IN) :: datatype
+ INTEGER(INT16), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_8b
- MODULE PURE FUNCTION intVec_get_8c(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_8c(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT32), INTENT(IN) :: DataType
- INTEGER(INT32), ALLOCATABLE :: Val(:)
+ INTEGER(INT32), INTENT(IN) :: datatype
+ INTEGER(INT32), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_8c
- MODULE PURE FUNCTION intVec_get_8d(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_8d(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT64), INTENT(IN) :: DataType
- INTEGER(INT64), ALLOCATABLE :: Val(:)
+ INTEGER(INT64), INTENT(IN) :: datatype
+ INTEGER(INT64), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_8d
END INTERFACE Get
@@ -213,32 +214,32 @@ END FUNCTION intVec_get_8d
INTERFACE Get
MODULE PURE FUNCTION intVec_get_9a(obj, iStart, iEnd, Stride,&
- & DataType) RESULT(Val)
+ & datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT8), INTENT(IN) :: DataType
- INTEGER(INT8), ALLOCATABLE :: Val(:)
+ INTEGER(INT8), INTENT(IN) :: datatype
+ INTEGER(INT8), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_9a
MODULE PURE FUNCTION intVec_get_9b(obj, iStart, iEnd, Stride,&
- & DataType) RESULT(Val)
+ & datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT16), INTENT(IN) :: DataType
- INTEGER(INT16), ALLOCATABLE :: Val(:)
+ INTEGER(INT16), INTENT(IN) :: datatype
+ INTEGER(INT16), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_9b
MODULE PURE FUNCTION intVec_get_9c(obj, iStart, iEnd, Stride,&
- & DataType) RESULT(Val)
+ & datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT32), INTENT(IN) :: DataType
- INTEGER(INT32), ALLOCATABLE :: Val(:)
+ INTEGER(INT32), INTENT(IN) :: datatype
+ INTEGER(INT32), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_9c
MODULE PURE FUNCTION intVec_get_9d(obj, iStart, iEnd, Stride,&
- & DataType) RESULT(Val)
+ & datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT64), INTENT(IN) :: DataType
- INTEGER(INT64), ALLOCATABLE :: Val(:)
+ INTEGER(INT64), INTENT(IN) :: datatype
+ INTEGER(INT64), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_9d
END INTERFACE Get
@@ -247,25 +248,25 @@ END FUNCTION intVec_get_9d
!----------------------------------------------------------------------------
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_10a(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_10a(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT8), INTENT(IN) :: DataType
- INTEGER(INT8), ALLOCATABLE :: Val(:)
+ INTEGER(INT8), INTENT(IN) :: datatype
+ INTEGER(INT8), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_10a
- MODULE PURE FUNCTION intVec_get_10b(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_10b(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT16), INTENT(IN) :: DataType
- INTEGER(INT16), ALLOCATABLE :: Val(:)
+ INTEGER(INT16), INTENT(IN) :: datatype
+ INTEGER(INT16), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_10b
- MODULE PURE FUNCTION intVec_get_10c(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_10c(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT32), INTENT(IN) :: DataType
- INTEGER(INT32), ALLOCATABLE :: Val(:)
+ INTEGER(INT32), INTENT(IN) :: datatype
+ INTEGER(INT32), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_10c
- MODULE PURE FUNCTION intVec_get_10d(obj, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_10d(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT64), INTENT(IN) :: DataType
- INTEGER(INT64), ALLOCATABLE :: Val(:)
+ INTEGER(INT64), INTENT(IN) :: datatype
+ INTEGER(INT64), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_10d
END INTERFACE Get
@@ -274,33 +275,33 @@ END FUNCTION intVec_get_10d
!----------------------------------------------------------------------------
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_11a(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_11a(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT8), INTENT(IN) :: DataType
+ INTEGER(INT8), INTENT(IN) :: datatype
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT8), ALLOCATABLE :: Val(:)
+ INTEGER(INT8), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_11a
- MODULE PURE FUNCTION intVec_get_11b(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_11b(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT16), INTENT(IN) :: DataType
+ INTEGER(INT16), INTENT(IN) :: datatype
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT16), ALLOCATABLE :: Val(:)
+ INTEGER(INT16), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_11b
- MODULE PURE FUNCTION intVec_get_11c(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_11c(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT32), INTENT(IN) :: DataType
+ INTEGER(INT32), INTENT(IN) :: datatype
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT32), ALLOCATABLE :: Val(:)
+ INTEGER(INT32), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_11c
- MODULE PURE FUNCTION intVec_get_11d(obj, Indx, DataType) &
- & RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_11d(obj, Indx, datatype) &
+ & RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
- INTEGER(INT64), INTENT(IN) :: DataType
+ INTEGER(INT64), INTENT(IN) :: datatype
INTEGER(I4B), INTENT(IN) :: Indx(:)
- INTEGER(INT64), ALLOCATABLE :: Val(:)
+ INTEGER(INT64), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_11d
END INTERFACE Get
@@ -310,32 +311,32 @@ END FUNCTION intVec_get_11d
INTERFACE Get
MODULE PURE FUNCTION intVec_get_12a(obj, iStart, iEnd, &
- & Stride, DataType) RESULT(Val)
+ & Stride, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT8), INTENT(IN) :: DataType
- INTEGER(INT8), ALLOCATABLE :: Val(:)
+ INTEGER(INT8), INTENT(IN) :: datatype
+ INTEGER(INT8), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_12a
MODULE PURE FUNCTION intVec_get_12b(obj, iStart, iEnd, &
- & Stride, DataType) RESULT(Val)
+ & Stride, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT16), INTENT(IN) :: DataType
- INTEGER(INT16), ALLOCATABLE :: Val(:)
+ INTEGER(INT16), INTENT(IN) :: datatype
+ INTEGER(INT16), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_12b
MODULE PURE FUNCTION intVec_get_12c(obj, iStart, iEnd, &
- & Stride, DataType) RESULT(Val)
+ & Stride, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT32), INTENT(IN) :: DataType
- INTEGER(INT32), ALLOCATABLE :: Val(:)
+ INTEGER(INT32), INTENT(IN) :: datatype
+ INTEGER(INT32), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_12c
MODULE PURE FUNCTION intVec_get_12d(obj, iStart, iEnd, &
- & Stride, DataType) RESULT(Val)
+ & Stride, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: iStart, iEnd, Stride
- INTEGER(INT64), INTENT(IN) :: DataType
- INTEGER(INT64), ALLOCATABLE :: Val(:)
+ INTEGER(INT64), INTENT(IN) :: datatype
+ INTEGER(INT64), ALLOCATABLE :: val(:)
END FUNCTION intVec_get_12d
END INTERFACE Get
@@ -344,28 +345,28 @@ END FUNCTION intVec_get_12d
!----------------------------------------------------------------------------
INTERFACE Get
- MODULE PURE FUNCTION intVec_get_13a(obj, indx, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_13a(obj, indx, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
- INTEGER(INT8), INTENT(IN) :: DataType
+ INTEGER(INT8), INTENT(IN) :: datatype
INTEGER(INT8) :: val
END FUNCTION intVec_get_13a
- MODULE PURE FUNCTION intVec_get_13b(obj, indx, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_13b(obj, indx, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
- INTEGER(INT16), INTENT(IN) :: DataType
+ INTEGER(INT16), INTENT(IN) :: datatype
INTEGER(INT16) :: val
END FUNCTION intVec_get_13b
- MODULE PURE FUNCTION intVec_get_13c(obj, indx, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_13c(obj, indx, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
- INTEGER(INT32), INTENT(IN) :: DataType
+ INTEGER(INT32), INTENT(IN) :: datatype
INTEGER(INT32) :: val
END FUNCTION intVec_get_13c
- MODULE PURE FUNCTION intVec_get_13d(obj, indx, DataType) RESULT(Val)
+ MODULE PURE FUNCTION intVec_get_13d(obj, indx, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
- INTEGER(INT64), INTENT(IN) :: DataType
+ INTEGER(INT64), INTENT(IN) :: datatype
INTEGER(INT64) :: val
END FUNCTION intVec_get_13d
END INTERFACE Get
@@ -375,10 +376,10 @@ END FUNCTION intVec_get_13d
!----------------------------------------------------------------------------
INTERFACE GetPointer
- MODULE FUNCTION intVec_getPointer_1(obj, DataType) RESULT(Val)
+ MODULE FUNCTION intVec_getPointer_1(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN), TARGET :: obj
- TYPE(IntVector_), INTENT(IN) :: DataType
- TYPE(IntVector_), POINTER :: Val
+ TYPE(IntVector_), INTENT(IN) :: datatype
+ TYPE(IntVector_), POINTER :: val
END FUNCTION intVec_getPointer_1
END INTERFACE GetPointer
@@ -387,10 +388,10 @@ END FUNCTION intVec_getPointer_1
!----------------------------------------------------------------------------
INTERFACE GetPointer
- MODULE FUNCTION intVec_getPointer_2(obj, DataType) RESULT(Val)
+ MODULE FUNCTION intVec_getPointer_2(obj, datatype) RESULT(val)
CLASS(IntVector_), INTENT(IN), TARGET :: obj
- INTEGER(I4B), INTENT(IN) :: DataType
- INTEGER(I4B), POINTER :: Val(:)
+ INTEGER(I4B), INTENT(IN) :: datatype
+ INTEGER(I4B), POINTER :: val(:)
END FUNCTION intVec_getPointer_2
END INTERFACE GetPointer
@@ -399,10 +400,10 @@ END FUNCTION intVec_getPointer_2
!----------------------------------------------------------------------------
INTERFACE GetIndex
- MODULE PURE FUNCTION intVec_getIndex1(obj, Val) RESULT(Ans)
+ MODULE PURE FUNCTION intVec_getIndex1(obj, val) RESULT(ans)
CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN) :: Val
- INTEGER(I4B) :: Ans
+ INTEGER(I4B), INTENT(IN) :: val
+ INTEGER(I4B) :: ans
END FUNCTION intVec_getIndex1
END INTERFACE GetIndex
@@ -411,10 +412,10 @@ END FUNCTION intVec_getIndex1
!----------------------------------------------------------------------------
INTERFACE GetIndex
- MODULE PURE FUNCTION intVec_getIndex2(obj, Val) RESULT(Ans)
+ MODULE PURE FUNCTION intVec_getIndex2(obj, val) RESULT(ans)
CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN) :: Val(:)
- INTEGER(I4B), ALLOCATABLE :: Ans(:)
+ INTEGER(I4B), INTENT(IN) :: val(:)
+ INTEGER(I4B), ALLOCATABLE :: ans(:)
END FUNCTION intVec_getIndex2
END INTERFACE GetIndex
diff --git a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90 b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90
index 923cbdd6b..25c14a7a9 100644
--- a/src/modules/Lapack/src/Sym_LinearSolveMethods.F90
+++ b/src/modules/Lapack/src/Sym_LinearSolveMethods.F90
@@ -22,7 +22,6 @@ MODULE Sym_LinearSolveMethods
IMPLICIT NONE
PRIVATE
-PUBLIC :: SymSolve
PUBLIC :: SymLinSolve
!----------------------------------------------------------------------------
@@ -59,9 +58,9 @@ MODULE Sym_LinearSolveMethods
! Therefore, when A is large this routine should be avoided.
!@endnote
-INTERFACE
+INTERFACE SymLinSolve
MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, &
- & UPLO, INFO)
+ UPLO, INFO)
REAL(DFP), INTENT(INOUT) :: X(:)
!! Unknown vector to be found
REAL(DFP), INTENT(IN) :: A(:, :)
@@ -81,14 +80,6 @@ MODULE SUBROUTINE SymLinSolve_1(X, A, B, preserveA, IPIV, SolverName, &
!! "U" or "L", Default is "U"
INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO
END SUBROUTINE SymLinSolve_1
-END INTERFACE
-
-INTERFACE SymSolve
- MODULE PROCEDURE SymLinSolve_1
-END INTERFACE SymSolve
-
-INTERFACE SymLinSolve
- MODULE PROCEDURE SymLinSolve_1
END INTERFACE SymLinSolve
!----------------------------------------------------------------------------
@@ -107,7 +98,7 @@ END SUBROUTINE SymLinSolve_1
!
! All other things are same as `ge_solve_1`.
-INTERFACE
+INTERFACE SymLinSolve
MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, &
& UPLO, INFO)
REAL(DFP), INTENT(INOUT) :: X(:, :)
@@ -127,16 +118,8 @@ MODULE SUBROUTINE SymLinSolve_2(X, A, B, preserveA, IPIV, SolverName, &
!! "U" or "L", default is "U"
INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO
END SUBROUTINE SymLinSolve_2
-END INTERFACE
-
-INTERFACE SymLinSolve
- MODULE PROCEDURE SymLinSolve_2
END INTERFACE SymLinSolve
-INTERFACE SymSolve
- MODULE PROCEDURE SymLinSolve_2
-END INTERFACE SymSolve
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -153,7 +136,7 @@ END SUBROUTINE SymLinSolve_2
! modified on return. Note that B will not be modified as we still
! make a copy of B.
-INTERFACE
+INTERFACE SymLinSolve
MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO)
REAL(DFP), INTENT(INOUT) :: X(:)
!! Unknown vector solution
@@ -169,16 +152,8 @@ MODULE SUBROUTINE SymLinSolve_3(X, A, B, IPIV, SolverName, UPLO, INFO)
!! "U" or "L", default is "U"
INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO
END SUBROUTINE SymLinSolve_3
-END INTERFACE
-
-INTERFACE SymLinSolve
- MODULE PROCEDURE SymLinSolve_3
END INTERFACE SymLinSolve
-INTERFACE SymSolve
- MODULE PROCEDURE SymLinSolve_3
-END INTERFACE SymSolve
-
!----------------------------------------------------------------------------
! LinSolve@LinearSolveMethods
!----------------------------------------------------------------------------
@@ -187,7 +162,7 @@ END SUBROUTINE SymLinSolve_3
! date: 7 July 2022
! summary: This function solves Ax=b using lapack DGESV x and b are 2d arrays
-INTERFACE
+INTERFACE SymLinSolve
MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO)
REAL(DFP), INTENT(INOUT) :: X(:, :)
!! Unknown vector or solution
@@ -203,16 +178,8 @@ MODULE SUBROUTINE SymLinSolve_4(X, A, B, IPIV, SolverName, UPLO, INFO)
!! "U" or "L", default is "U"
INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO
END SUBROUTINE SymLinSolve_4
-END INTERFACE
-
-INTERFACE SymLinSolve
- MODULE PROCEDURE SymLinSolve_4
END INTERFACE SymLinSolve
-INTERFACE Solve
- MODULE PROCEDURE SymLinSolve_4
-END INTERFACE Solve
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -228,7 +195,7 @@ END SUBROUTINE SymLinSolve_4
! We do not make any copy of B. The solution is returned in B. This
! means B will be destroyed on return.
-INTERFACE
+INTERFACE SymLinSolve
MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info)
REAL(DFP), INTENT(INOUT) :: A(:, :)
!! General square symmetric matrix, its content will be modified on
@@ -243,16 +210,8 @@ MODULE SUBROUTINE SymLinSolve_5(A, B, IPIV, SolverName, UPLO, info)
!! "L" or "U", default is "U"
INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO
END SUBROUTINE SymLinSolve_5
-END INTERFACE
-
-INTERFACE SymLinSolve
- MODULE PROCEDURE SymLinSolve_5
END INTERFACE SymLinSolve
-INTERFACE SymSolve
- MODULE PROCEDURE SymLinSolve_5
-END INTERFACE SymSolve
-
!----------------------------------------------------------------------------
! LinSolve@LinearSolveMethods
!----------------------------------------------------------------------------
@@ -261,7 +220,7 @@ END SUBROUTINE SymLinSolve_5
! date: 28 July 2022
! summary: Solve Ax=y
-INTERFACE
+INTERFACE SymLinSolve
MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO)
REAL(DFP), INTENT(INOUT) :: A(:, :)
!! General square/rectangle matrix, its content will be modifie
@@ -277,14 +236,6 @@ MODULE SUBROUTINE SymLinSolve_6(A, B, IPIV, SolverName, UPLO, INFO)
!! "U" or "L", default is "U"
INTEGER(I4B), OPTIONAL, INTENT(OUT) :: INFO
END SUBROUTINE SymLinSolve_6
-END INTERFACE
-
-INTERFACE SymLinSolve
- MODULE PROCEDURE SymLinSolve_6
END INTERFACE SymLinSolve
-INTERFACE SymSolve
- MODULE PROCEDURE SymLinSolve_6
-END INTERFACE SymSolve
-
END MODULE Sym_LinearSolveMethods
diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90
index c2b6ab317..7b7eeafa6 100644
--- a/src/modules/MassMatrix/src/MassMatrix_Method.F90
+++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90
@@ -26,6 +26,7 @@ MODULE MassMatrix_Method
PRIVATE
PUBLIC :: MassMatrix
+PUBLIC :: MassMatrix_
PUBLIC :: ViscousBoundaryMassMatrix
!----------------------------------------------------------------------------
@@ -56,6 +57,20 @@ MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans)
END FUNCTION MassMatrix_1
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE MassMatrix_
+ MODULE PURE SUBROUTINE MassMatrix1_(test, trial, ans, nrow, ncol, opt)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ END SUBROUTINE MassMatrix1_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
@@ -80,6 +95,23 @@ MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) &
END FUNCTION MassMatrix_2
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE MassMatrix_
+ MODULE PURE SUBROUTINE MassMatrix2_(test, trial, rho, rhorank, &
+ ans, nrow, ncol, opt)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: rho
+ TYPE(FEVariableScalar_), INTENT(IN) :: rhorank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ END SUBROUTINE MassMatrix2_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
@@ -104,6 +136,27 @@ MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) &
END FUNCTION MassMatrix_3
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-02
+! summary: mass matrix in space
+! notice: not implemented yet
+
+INTERFACE MassMatrix_
+ MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, &
+ opt, nrow, ncol, ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: rho
+ INTEGER(I4B), INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ END SUBROUTINE MassMatrix3_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
@@ -126,6 +179,27 @@ MODULE PURE FUNCTION MassMatrix_4(test, trial, rho, rhorank) &
END FUNCTION MassMatrix_4
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-02
+! summary: mass matrix in space
+! notice: not implemented yet
+
+INTERFACE MassMatrix_
+ MODULE PURE SUBROUTINE MassMatrix4_(test, trial, rho, rhorank, &
+ nrow, ncol, ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: rho
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ END SUBROUTINE MassMatrix4_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
diff --git a/src/modules/PENF/src/penf.F90 b/src/modules/PENF/src/penf.F90
index 720764b20..c444c6bb0 100644
--- a/src/modules/PENF/src/penf.F90
+++ b/src/modules/PENF/src/penf.F90
@@ -1,129 +1,129 @@
!< Portability Environment for Fortran poor people.
-module penf
+MODULE penf
!< Portability Environment for Fortran poor people.
-use penf_global_parameters_variables
+USE penf_global_parameters_variables
#ifdef __INTEL_COMPILER
-use penf_b_size
+USE penf_b_size
#else
-use penf_b_size, only : bit_size, byte_size
+USE penf_b_size, ONLY: bit_size, byte_size
#endif
-use penf_stringify, only : str_ascii, str_ucs4, str, strz, cton, bstr, bcton
+USE penf_stringify, ONLY: str_ascii, str_ucs4, str, strz, cton, bstr, bcton
-implicit none
-private
-save
+IMPLICIT NONE
+PRIVATE
+SAVE
! global parameters and variables
-public :: endianL, endianB, endian, is_initialized
-public :: ASCII, UCS4, CK
+PUBLIC :: endianL, endianB, endian, is_initialized
+PUBLIC :: ASCII, UCS4, CK
public :: R16P, FR16P, DR16P, MinR16P, MaxR16P, BIR16P, BYR16P, smallR16P, ZeroR16P
-public :: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8P
-public :: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4P
-public :: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, ZeroR_P
-public :: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P
-public :: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P
-public :: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P
-public :: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P
-public :: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P
-public :: CHARACTER_KINDS_LIST, REAL_KINDS_LIST, REAL_FORMATS_LIST
-public :: INTEGER_KINDS_LIST, INTEGER_FORMATS_LIST
+PUBLIC :: R8P, FR8P, DR8P, MinR8P, MaxR8P, BIR8P, BYR8P, smallR8P, ZeroR8P
+PUBLIC :: R4P, FR4P, DR4P, MinR4P, MaxR4P, BIR4P, BYR4P, smallR4P, ZeroR4P
+PUBLIC :: R_P, FR_P, DR_P, MinR_P, MaxR_P, BIR_P, BYR_P, smallR_P, ZeroR_P
+PUBLIC :: I8P, FI8P, DI8P, MinI8P, MaxI8P, BII8P, BYI8P
+PUBLIC :: I4P, FI4P, DI4P, MinI4P, MaxI4P, BII4P, BYI4P
+PUBLIC :: I2P, FI2P, DI2P, MinI2P, MaxI2P, BII2P, BYI2P
+PUBLIC :: I1P, FI1P, DI1P, MinI1P, MaxI1P, BII1P, BYI1P
+PUBLIC :: I_P, FI_P, DI_P, MinI_P, MaxI_P, BII_P, BYI_P
+PUBLIC :: CHARACTER_KINDS_LIST, REAL_KINDS_LIST, REAL_FORMATS_LIST
+PUBLIC :: INTEGER_KINDS_LIST, INTEGER_FORMATS_LIST
! bit/byte size functions
-public :: bit_size, byte_size
+PUBLIC :: bit_size, byte_size
! stringify facility
-public :: str_ascii, str_ucs4
-public :: str, strz, cton
-public :: bstr, bcton
+PUBLIC :: str_ascii, str_ucs4
+PUBLIC :: str, strz, cton
+PUBLIC :: bstr, bcton
! miscellanea facility
-public :: check_endian
-public :: digit
-public :: penf_Init
-public :: penf_print
+PUBLIC :: check_endian
+PUBLIC :: digit
+PUBLIC :: penf_Init
+PUBLIC :: penf_print
-integer, protected :: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB).
-logical, protected :: is_initialized = .false. !< Check the initialization of some variables that must be initialized.
+INTEGER, PROTECTED :: endian = endianL !< Bit ordering: Little endian (endianL), or Big endian (endianB).
+LOGICAL, PROTECTED :: is_initialized = .FALSE. !< Check the initialization of some variables that must be initialized.
#ifdef __GFORTRAN__
! work-around for strange gfortran bug...
-interface bit_size
+INTERFACE bit_size
!< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables.
-endinterface
+END INTERFACE
#endif
-interface digit
+INTERFACE digit
!< Compute the number of digits in decimal base of the input integer.
- module procedure digit_I8, digit_I4, digit_I2, digit_I1
-endinterface
-
-contains
- ! public procedures
- subroutine check_endian()
- !< Check the type of bit ordering (big or little endian) of the running architecture.
- !<
- !> @note The result is stored into the *endian* global variable.
- !<
- !<```fortran
- !< use penf
- !< call check_endian
- !< print *, endian
- !<```
- !=> 1 <<<
- if (is_little_endian()) then
- endian = endianL
- else
- endian = endianB
- endif
- contains
- pure function is_little_endian() result(is_little)
- !< Check if the type of the bit ordering of the running architecture is little endian.
- logical :: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise.
- integer(I1P) :: int1(1:4) !< One byte integer array for casting 4 bytes integer.
-
- int1 = transfer(1_I4P, int1)
- is_little = (int1(1)==1_I1P)
- endfunction is_little_endian
- endsubroutine check_endian
-
- subroutine penf_init()
- !< Initialize PENF's variables that are not initialized into the definition specification.
- !<
- !<```fortran
- !< use penf
- !< call penf_init
- !< print FI1P, BYR4P
- !<```
- !=> 4 <<<
-
- call check_endian
- is_initialized = .true.
- endsubroutine penf_init
-
- subroutine penf_print(unit, pref, iostat, iomsg)
- !< Print to the specified unit the PENF's environment data.
- !<
- !<```fortran
- !< use penf
- !< integer :: u
- !< open(newunit=u, status='scratch')
- !< call penf_print(u)
- !< close(u)
- !< print "(A)", 'done'
- !<```
- !=> done <<<
- integer(I4P), intent(in) :: unit !< Logic unit.
- character(*), intent(in), optional :: pref !< Prefixing string.
- integer(I4P), intent(out), optional :: iostat !< IO error.
- character(*), intent(out), optional :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
-
- if (.not.is_initialized) call penf_init
- prefd = '' ; if (present(pref)) prefd = pref
- if (endian==endianL) then
+ MODULE PROCEDURE digit_I8, digit_I4, digit_I2, digit_I1
+END INTERFACE
+
+CONTAINS
+! public procedures
+SUBROUTINE check_endian()
+ !< Check the type of bit ordering (big or little endian) of the running architecture.
+ !<
+ !> @note The result is stored into the *endian* global variable.
+ !<
+ !<```fortran
+ !< use penf
+ !< call check_endian
+ !< print *, endian
+ !<```
+ !=> 1 <<<
+ IF (is_little_endian()) THEN
+ endian = endianL
+ ELSE
+ endian = endianB
+ END IF
+CONTAINS
+ PURE FUNCTION is_little_endian() RESULT(is_little)
+ !< Check if the type of the bit ordering of the running architecture is little endian.
+ LOGICAL :: is_little !< Logical output: true is the running architecture uses little endian ordering, false otherwise.
+ INTEGER(I1P) :: int1(1:4) !< One byte integer array for casting 4 bytes integer.
+
+ int1 = TRANSFER(1_I4P, int1)
+ is_little = (int1(1) == 1_I1P)
+ END FUNCTION is_little_endian
+END SUBROUTINE check_endian
+
+SUBROUTINE penf_init()
+ !< Initialize PENF's variables that are not initialized into the definition specification.
+ !<
+ !<```fortran
+ !< use penf
+ !< call penf_init
+ !< print FI1P, BYR4P
+ !<```
+ !=> 4 <<<
+
+ CALL check_endian
+ is_initialized = .TRUE.
+END SUBROUTINE penf_init
+
+SUBROUTINE penf_print(unit, pref, iostat, iomsg)
+ !< Print to the specified unit the PENF's environment data.
+ !<
+ !<```fortran
+ !< use penf
+ !< integer :: u
+ !< open(newunit=u, status='scratch')
+ !< call penf_print(u)
+ !< close(u)
+ !< print "(A)", 'done'
+ !<```
+ !=> done <<<
+ INTEGER(I4P), INTENT(in) :: unit !< Logic unit.
+ CHARACTER(*), INTENT(in), OPTIONAL :: pref !< Prefixing string.
+ INTEGER(I4P), INTENT(out), OPTIONAL :: iostat !< IO error.
+ CHARACTER(*), INTENT(out), OPTIONAL :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+
+ IF (.NOT. is_initialized) CALL penf_init
+ prefd = ''; IF (PRESENT(pref)) prefd = pref
+ IF (endian == endianL) THEN
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has LITTLE Endian bit ordering'
- else
+ ELSE
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd)prefd//'This architecture has BIG Endian bit ordering'
- endif
+ END IF
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Character kind:'
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ASCII: '//str(n=ASCII)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' UCS4: '//str(n=UCS4)
@@ -163,77 +163,77 @@ subroutine penf_print(unit, pref, iostat, iomsg)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR8P: '//str(smallR8P, .true.)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR4P: '//str(smallR4P, .true.)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' smallR_P: '//str(smallR_P, .true.)
- write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Machine zero'
+ write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//'Machine zero'
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR16P: '//str(ZeroR16P, .true.)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR8P: '//str(ZeroR8P, .true.)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR4P: '//str(ZeroR4P, .true.)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' ZeroR_P: '//str(ZeroR_P, .true.)
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- endsubroutine penf_print
-
- ! private procedures
- elemental function digit_I8(n) result(digit)
- !< Compute the number of digits in decimal base of the input integer.
- !<
- !<```fortran
- !< use penf
- !< print FI4P, digit(100_I8P)
- !<```
- !=> 3 <<<
- integer(I8P), intent(in) :: n !< Input integer.
- character(DI8P) :: str !< Returned string containing input number plus padding zeros.
- integer(I4P) :: digit !< Number of digits.
-
- write(str, FI8P) abs(n) ! Casting of n to string.
- digit = len_trim(adjustl(str)) ! Calculating the digits number of n.
- endfunction digit_I8
-
- elemental function digit_I4(n) result(digit)
- !< Compute the number of digits in decimal base of the input integer.
- !<
- !<```fortran
- !< use penf
- !< print FI4P, digit(100_I4P)
- !<```
- !=> 3 <<<
- integer(I4P), intent(in) :: n !< Input integer.
- character(DI4P) :: str !< Returned string containing input number plus padding zeros.
- integer(I4P) :: digit !< Number of digits.
-
- write(str, FI4P) abs(n) ! Casting of n to string.
- digit = len_trim(adjustl(str)) ! Calculating the digits number of n.
- endfunction digit_I4
-
- elemental function digit_I2(n) result(digit)
- !< Compute the number of digits in decimal base of the input integer.
- !<
- !<```fortran
- !< use penf
- !< print FI4P, digit(100_I2P)
- !<```
- !=> 3 <<<
- integer(I2P), intent(in) :: n !< Input integer.
- character(DI2P) :: str !< Returned string containing input number plus padding zeros.
- integer(I4P) :: digit !< Number of digits.
-
- write(str, FI2P) abs(n) ! Casting of n to string.
- digit = len_trim(adjustl(str)) ! Calculating the digits number of n.
- endfunction digit_I2
-
- elemental function digit_I1(n) result(digit)
- !< Compute the number of digits in decimal base of the input integer.
- !<
- !<```fortran
- !< use penf
- !< print FI4P, digit(100_I1P)
- !<```
- !=> 3 <<<
- integer(I1P), intent(in) :: n !< Input integer.
- character(DI1P) :: str !< Returned string containing input number plus padding zeros.
- integer(I4P) :: digit !< Number of digits.
-
- write(str, FI1P) abs(n) ! Casting of n to string.
- digit = len_trim(adjustl(str)) ! Calculating the digits number of n.
- endfunction digit_I1
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE penf_print
+
+! private procedures
+ELEMENTAL FUNCTION digit_I8(n) RESULT(digit)
+ !< Compute the number of digits in decimal base of the input integer.
+ !<
+ !<```fortran
+ !< use penf
+ !< print FI4P, digit(100_I8P)
+ !<```
+ !=> 3 <<<
+ INTEGER(I8P), INTENT(in) :: n !< Input integer.
+ CHARACTER(DI8P) :: str !< Returned string containing input number plus padding zeros.
+ INTEGER(I4P) :: digit !< Number of digits.
+
+ WRITE (str, FI8P) ABS(n) ! Casting of n to string.
+ digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n.
+END FUNCTION digit_I8
+
+ELEMENTAL FUNCTION digit_I4(n) RESULT(digit)
+ !< Compute the number of digits in decimal base of the input integer.
+ !<
+ !<```fortran
+ !< use penf
+ !< print FI4P, digit(100_I4P)
+ !<```
+ !=> 3 <<<
+ INTEGER(I4P), INTENT(in) :: n !< Input integer.
+ CHARACTER(DI4P) :: str !< Returned string containing input number plus padding zeros.
+ INTEGER(I4P) :: digit !< Number of digits.
+
+ WRITE (str, FI4P) ABS(n) ! Casting of n to string.
+ digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n.
+END FUNCTION digit_I4
+
+ELEMENTAL FUNCTION digit_I2(n) RESULT(digit)
+ !< Compute the number of digits in decimal base of the input integer.
+ !<
+ !<```fortran
+ !< use penf
+ !< print FI4P, digit(100_I2P)
+ !<```
+ !=> 3 <<<
+ INTEGER(I2P), INTENT(in) :: n !< Input integer.
+ CHARACTER(DI2P) :: str !< Returned string containing input number plus padding zeros.
+ INTEGER(I4P) :: digit !< Number of digits.
+
+ WRITE (str, FI2P) ABS(n) ! Casting of n to string.
+ digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n.
+END FUNCTION digit_I2
+
+ELEMENTAL FUNCTION digit_I1(n) RESULT(digit)
+ !< Compute the number of digits in decimal base of the input integer.
+ !<
+ !<```fortran
+ !< use penf
+ !< print FI4P, digit(100_I1P)
+ !<```
+ !=> 3 <<<
+ INTEGER(I1P), INTENT(in) :: n !< Input integer.
+ CHARACTER(DI1P) :: str !< Returned string containing input number plus padding zeros.
+ INTEGER(I4P) :: digit !< Number of digits.
+
+ WRITE (str, FI1P) ABS(n) ! Casting of n to string.
+ digit = LEN_TRIM(ADJUSTL(str)) ! Calculating the digits number of n.
+END FUNCTION digit_I1
endmodule penf
diff --git a/src/modules/PENF/src/penf_b_size.F90 b/src/modules/PENF/src/penf_b_size.F90
index 13054b874..ff3b61dc1 100644
--- a/src/modules/PENF/src/penf_b_size.F90
+++ b/src/modules/PENF/src/penf_b_size.F90
@@ -17,29 +17,29 @@
!< PENF bit/byte size functions.
-module penf_b_size
+MODULE penf_b_size
!< PENF bit/byte size functions.
-use penf_global_parameters_variables
+USE penf_global_parameters_variables
-implicit none
-private
-save
-public :: bit_size, byte_size
+IMPLICIT NONE
+PRIVATE
+SAVE
+PUBLIC :: bit_size, byte_size
-interface bit_size
+INTERFACE bit_size
!< Overloading of the intrinsic *bit_size* function for computing the number of bits of (also) real and character variables.
- module procedure &
+ MODULE PROCEDURE &
#if defined _R16P
bit_size_R16P, &
#endif
bit_size_R8P, &
bit_size_R4P, &
bit_size_chr
-end interface
+END INTERFACE
-interface byte_size
+INTERFACE byte_size
!< Compute the number of bytes of a variable.
- module procedure &
+ MODULE PROCEDURE &
byte_size_I8P, &
byte_size_I4P, &
byte_size_I2P, &
@@ -50,10 +50,10 @@ module penf_b_size
byte_size_R8P, &
byte_size_R4P, &
byte_size_chr
-end interface
+END INTERFACE
-contains
-elemental function bit_size_R16P(i) result(bits)
+CONTAINS
+ELEMENTAL FUNCTION bit_size_R16P(i) RESULT(bits)
!< Compute the number of bits of a real variable.
!<
!<```fortran
@@ -61,14 +61,14 @@ elemental function bit_size_R16P(i) result(bits)
!< print FI2P, bit_size(1._R16P)
!<```
!=> 128 <<<
- real(R16P), intent(in) :: i !< Real variable whose number of bits must be computed.
- integer(I2P) :: bits !< Number of bits of r.
- integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
+ REAL(R16P), INTENT(in) :: i !< Real variable whose number of bits must be computed.
+ INTEGER(I2P) :: bits !< Number of bits of r.
+ INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
- bits = size(transfer(i, mold), dim=1, kind=I2P) * 8_I2P
-end function bit_size_R16P
+ bits = SIZE(TRANSFER(i, mold), dim=1, kind=I2P) * 8_I2P
+END FUNCTION bit_size_R16P
-elemental function bit_size_R8P(i) result(bits)
+ELEMENTAL FUNCTION bit_size_R8P(i) RESULT(bits)
!< Compute the number of bits of a real variable.
!<
!<```fortran
@@ -76,14 +76,14 @@ elemental function bit_size_R8P(i) result(bits)
!< print FI1P, bit_size(1._R8P)
!<```
!=> 64 <<<
- real(R8P), intent(in) :: i !< Real variable whose number of bits must be computed.
- integer(I1P) :: bits !< Number of bits of r.
- integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
+ REAL(R8P), INTENT(in) :: i !< Real variable whose number of bits must be computed.
+ INTEGER(I1P) :: bits !< Number of bits of r.
+ INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
- bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P
-end function bit_size_R8P
+ bits = SIZE(TRANSFER(i, mold), dim=1, kind=I1P) * 8_I1P
+END FUNCTION bit_size_R8P
-elemental function bit_size_R4P(i) result(bits)
+ELEMENTAL FUNCTION bit_size_R4P(i) RESULT(bits)
!< Compute the number of bits of a real variable.
!<
!<```fortran
@@ -91,14 +91,14 @@ elemental function bit_size_R4P(i) result(bits)
!< print FI1P, bit_size(1._R4P)
!<```
!=> 32 <<<
- real(R4P), intent(in) :: i !< Real variable whose number of bits must be computed.
- integer(I1P) :: bits !< Number of bits of r.
- integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
+ REAL(R4P), INTENT(in) :: i !< Real variable whose number of bits must be computed.
+ INTEGER(I1P) :: bits !< Number of bits of r.
+ INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
- bits = size(transfer(i, mold), dim=1, kind=I1P) * 8_I1P
-end function bit_size_R4P
+ bits = SIZE(TRANSFER(i, mold), dim=1, kind=I1P) * 8_I1P
+END FUNCTION bit_size_R4P
-elemental function bit_size_chr(i) result(bits)
+ELEMENTAL FUNCTION bit_size_chr(i) RESULT(bits)
!< Compute the number of bits of a character variable.
!<
!<```fortran
@@ -106,14 +106,14 @@ elemental function bit_size_chr(i) result(bits)
!< print FI4P, bit_size('ab')
!<```
!=> 16 <<<
- character(*), intent(IN) :: i !< Character variable whose number of bits must be computed.
- integer(I4P) :: bits !< Number of bits of c.
- integer(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
+ CHARACTER(*), INTENT(IN) :: i !< Character variable whose number of bits must be computed.
+ INTEGER(I4P) :: bits !< Number of bits of c.
+ INTEGER(I1P) :: mold(1) !< "Molding" dummy variable for bits counting.
- bits = size(transfer(i, mold), dim=1, kind=I4P) * 8_I4P
-end function bit_size_chr
+ bits = SIZE(TRANSFER(i, mold), dim=1, kind=I4P) * 8_I4P
+END FUNCTION bit_size_chr
-elemental function byte_size_R16P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_R16P(i) RESULT(bytes)
!< Compute the number of bytes of a real variable.
!<
!<```fortran
@@ -121,13 +121,13 @@ elemental function byte_size_R16P(i) result(bytes)
!< print FI1P, byte_size(1._R16P)
!<```
!=> 16 <<<
- real(R16P), intent(in) :: i !< Real variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of r.
+ REAL(R16P), INTENT(in) :: i !< Real variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of r.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_R16P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_R16P
-elemental function byte_size_R8P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_R8P(i) RESULT(bytes)
!< Compute the number of bytes of a real variable.
!<
!<```fortran
@@ -135,13 +135,13 @@ elemental function byte_size_R8P(i) result(bytes)
!< print FI1P, byte_size(1._R8P)
!<```
!=> 8 <<<
- real(R8P), intent(in) :: i !< Real variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of r.
+ REAL(R8P), INTENT(in) :: i !< Real variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of r.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_R8P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_R8P
-elemental function byte_size_R4P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_R4P(i) RESULT(bytes)
!< Compute the number of bytes of a real variable.
!<
!<```fortran
@@ -149,13 +149,13 @@ elemental function byte_size_R4P(i) result(bytes)
!< print FI1P, byte_size(1._R4P)
!<```
!=> 4 <<<
- real(R4P), intent(in) :: i !< Real variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of r.
+ REAL(R4P), INTENT(in) :: i !< Real variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of r.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_R4P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_R4P
-elemental function byte_size_chr(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_chr(i) RESULT(bytes)
!< Compute the number of bytes of a character variable.
!<
!<```fortran
@@ -163,13 +163,13 @@ elemental function byte_size_chr(i) result(bytes)
!< print FI1P, byte_size('ab')
!<```
!=> 2 <<<
- character(*), intent(in) :: i !< Character variable whose number of bytes must be computed.
- integer(I4P) :: bytes !< Number of bytes of c.
+ CHARACTER(*), INTENT(in) :: i !< Character variable whose number of bytes must be computed.
+ INTEGER(I4P) :: bytes !< Number of bytes of c.
- bytes = bit_size(i) / 8_I4P
-end function byte_size_chr
+ bytes = BIT_SIZE(i) / 8_I4P
+END FUNCTION byte_size_chr
-elemental function byte_size_I8P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_I8P(i) RESULT(bytes)
!< Compute the number of bytes of an integer variable.
!<
!<```fortran
@@ -177,13 +177,13 @@ elemental function byte_size_I8P(i) result(bytes)
!< print FI1P, byte_size(1_I8P)
!<```
!=> 8 <<<
- integer(I8P), intent(in) :: i !< Integer variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of i.
+ INTEGER(I8P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of i.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_I8P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_I8P
-elemental function byte_size_I4P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_I4P(i) RESULT(bytes)
!< Compute the number of bytes of an integer variable.
!<
!<```fortran
@@ -191,13 +191,13 @@ elemental function byte_size_I4P(i) result(bytes)
!< print FI1P, byte_size(1_I4P)
!<```
!=> 4 <<<
- integer(I4P), intent(in) :: i !< Integer variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of i.
+ INTEGER(I4P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of i.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_I4P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_I4P
-elemental function byte_size_I2P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_I2P(i) RESULT(bytes)
!< Compute the number of bytes of an integer variable.
!<
!<```fortran
@@ -205,13 +205,13 @@ elemental function byte_size_I2P(i) result(bytes)
!< print FI1P, byte_size(1_I2P)
!<```
!=> 2 <<<
- integer(I2P), intent(in) :: i !< Integer variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of i.
+ INTEGER(I2P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of i.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_I2P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_I2P
-elemental function byte_size_I1P(i) result(bytes)
+ELEMENTAL FUNCTION byte_size_I1P(i) RESULT(bytes)
!< Compute the number of bytes of an integer variable.
!<
!<```fortran
@@ -219,9 +219,9 @@ elemental function byte_size_I1P(i) result(bytes)
!< print FI1P, byte_size(1_I1P)
!<```
!=> 1 <<<
- integer(I1P), intent(in) :: i !< Integer variable whose number of bytes must be computed.
- integer(I1P) :: bytes !< Number of bytes of i.
+ INTEGER(I1P), INTENT(in) :: i !< Integer variable whose number of bytes must be computed.
+ INTEGER(I1P) :: bytes !< Number of bytes of i.
- bytes = bit_size(i) / 8_I1P
-end function byte_size_I1P
+ bytes = BIT_SIZE(i) / 8_I1P
+END FUNCTION byte_size_I1P
endmodule penf_b_size
diff --git a/src/modules/PENF/src/penf_global_parameters_variables.F90 b/src/modules/PENF/src/penf_global_parameters_variables.F90
index 356764dc9..8ebe73820 100644
--- a/src/modules/PENF/src/penf_global_parameters_variables.F90
+++ b/src/modules/PENF/src/penf_global_parameters_variables.F90
@@ -1,213 +1,213 @@
!< PENF global parameters and variables.
-module penf_global_parameters_variables
+MODULE penf_global_parameters_variables
!< PENF global parameters and variables.
!<
!< @note All module defined entities are public.
-implicit none
-public
-save
+IMPLICIT NONE
+PUBLIC
+SAVE
-integer, parameter :: endianL = 1 !< Little endian parameter.
-integer, parameter :: endianB = 0 !< Big endian parameter.
+INTEGER, PARAMETER :: endianL = 1 !< Little endian parameter.
+INTEGER, PARAMETER :: endianB = 0 !< Big endian parameter.
! portable kind parameters
#ifdef _ASCII_SUPPORTED
-integer, parameter :: ASCII = selected_char_kind('ascii') !< ASCII character set kind.
+INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('ascii') !< ASCII character set kind.
#else
-integer, parameter :: ASCII = selected_char_kind('default') !< ASCII character set kind defined as default set.
+INTEGER, PARAMETER :: ASCII = SELECTED_CHAR_KIND('default') !< ASCII character set kind defined as default set.
#endif
#ifdef _UCS4_SUPPORTED
-integer, parameter :: UCS4 = selected_char_kind('iso_10646') !< Unicode character set kind.
+INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('iso_10646') !< Unicode character set kind.
#else
-integer, parameter :: UCS4 = selected_char_kind('default') !< Unicode character set kind defined as default set.
+INTEGER, PARAMETER :: UCS4 = SELECTED_CHAR_KIND('default') !< Unicode character set kind defined as default set.
#endif
#if defined _CK_IS_DEFAULT
-integer, parameter :: CK = selected_char_kind('default') !< Default kind character.
+INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('default') !< Default kind character.
#elif defined _CK_IS_ASCII
-integer, parameter :: CK = ASCII !< Default kind character.
+INTEGER, PARAMETER :: CK = ASCII !< Default kind character.
#elif defined _CK_IS_UCS4
-integer, parameter :: CK = UCS4 !< Default kind character.
+INTEGER, PARAMETER :: CK = UCS4 !< Default kind character.
#else
-integer, parameter :: CK = selected_char_kind('default') !< Default kind character.
+INTEGER, PARAMETER :: CK = SELECTED_CHAR_KIND('default') !< Default kind character.
#endif
#if defined _R16P
-integer, parameter :: R16P = selected_real_kind(33,4931) !< 33 digits, range \([10^{-4931}, 10^{+4931} - 1]\); 128 bits.
+INTEGER, PARAMETER :: R16P = SELECTED_REAL_KIND(33, 4931) !< 33 digits, range \([10^{-4931}, 10^{+4931} - 1]\); 128 bits.
#else
-integer, parameter :: R16P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits.
+INTEGER, PARAMETER :: R16P = SELECTED_REAL_KIND(15, 307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits.
#endif
-integer, parameter :: R8P = selected_real_kind(15,307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits.
-integer, parameter :: R4P = selected_real_kind(6,37) !< 6 digits, range \([10^{-37} , 10^{+37} - 1]\); 32 bits.
+INTEGER, PARAMETER :: R8P = SELECTED_REAL_KIND(15, 307) !< 15 digits, range \([10^{-307} , 10^{+307} - 1]\); 64 bits.
+INTEGER, PARAMETER :: R4P = SELECTED_REAL_KIND(6, 37) !< 6 digits, range \([10^{-37} , 10^{+37} - 1]\); 32 bits.
#if defined _R16P
#if defined _R_P_IS_R16P
-integer, parameter :: R_P = R16P !< Default real precision.
+INTEGER, PARAMETER :: R_P = R16P !< Default real precision.
#endif
#endif
#if defined _R_P_IS_R8P
-integer, parameter :: R_P = R8P !< Default real precision.
+INTEGER, PARAMETER :: R_P = R8P !< Default real precision.
#elif defined _R_P_IS_R4P
-integer, parameter :: R_P = R4P !< Default real precision.
+INTEGER, PARAMETER :: R_P = R4P !< Default real precision.
#else
-integer, parameter :: R_P = R8P !< Default real precision.
+INTEGER, PARAMETER :: R_P = R8P !< Default real precision.
#endif
-integer, parameter :: I8P = selected_int_kind(18) !< Range \([-2^{63},+2^{63} - 1]\), 19 digits plus sign; 64 bits.
-integer, parameter :: I4P = selected_int_kind(9) !< Range \([-2^{31},+2^{31} - 1]\), 10 digits plus sign; 32 bits.
-integer, parameter :: I2P = selected_int_kind(4) !< Range \([-2^{15},+2^{15} - 1]\), 5 digits plus sign; 16 bits.
-integer, parameter :: I1P = selected_int_kind(2) !< Range \([-2^{7} ,+2^{7} - 1]\), 3 digits plus sign; 8 bits.
-integer, parameter :: I_P = I4P !< Default integer precision.
+INTEGER, PARAMETER :: I8P = SELECTED_INT_KIND(18) !< Range \([-2^{63},+2^{63} - 1]\), 19 digits plus sign; 64 bits.
+INTEGER, PARAMETER :: I4P = SELECTED_INT_KIND(9) !< Range \([-2^{31},+2^{31} - 1]\), 10 digits plus sign; 32 bits.
+INTEGER, PARAMETER :: I2P = SELECTED_INT_KIND(4) !< Range \([-2^{15},+2^{15} - 1]\), 5 digits plus sign; 16 bits.
+INTEGER, PARAMETER :: I1P = SELECTED_INT_KIND(2) !< Range \([-2^{7} ,+2^{7} - 1]\), 3 digits plus sign; 8 bits.
+INTEGER, PARAMETER :: I_P = I4P !< Default integer precision.
! format parameters
#if defined _R16P
-character(*), parameter :: FR16P = '(E42.33E4)' !< Output format for kind=R16P real.
+CHARACTER(*), PARAMETER :: FR16P = '(E42.33E4)' !< Output format for kind=R16P real.
#else
-character(*), parameter :: FR16P = '(E23.15E3)' !< Output format for kind=R8P real.
+CHARACTER(*), PARAMETER :: FR16P = '(E23.15E3)' !< Output format for kind=R8P real.
#endif
-character(*), parameter :: FR8P = '(E23.15E3)' !< Output format for kind=R8P real.
-character(*), parameter :: FR4P = '(E13.6E2)' !< Output format for kind=R4P real.
+CHARACTER(*), PARAMETER :: FR8P = '(E23.15E3)' !< Output format for kind=R8P real.
+CHARACTER(*), PARAMETER :: FR4P = '(E13.6E2)' !< Output format for kind=R4P real.
#if defined _R16P
#if defined _R_P_IS_R16P
-character(*), parameter :: FR_P = FR16P !< Output format for kind=R_P real.
+CHARACTER(*), PARAMETER :: FR_P = FR16P !< Output format for kind=R_P real.
#endif
#endif
#if defined _R_P_IS_R8P
-character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real.
+CHARACTER(*), PARAMETER :: FR_P = FR8P !< Output format for kind=R_P real.
#elif defined _R_P_IS_R4P
-character(*), parameter :: FR_P = FR4P !< Output format for kind=R_P real.
+CHARACTER(*), PARAMETER :: FR_P = FR4P !< Output format for kind=R_P real.
#else
-character(*), parameter :: FR_P = FR8P !< Output format for kind=R_P real.
+CHARACTER(*), PARAMETER :: FR_P = FR8P !< Output format for kind=R_P real.
#endif
-character(*), parameter :: FI8P = '(I20)' !< Output format for kind=I8P integer.
-character(*), parameter :: FI8PZP = '(I20.19)' !< Output format for kind=I8P integer with zero prefixing.
-character(*), parameter :: FI4P = '(I11)' !< Output format for kind=I4P integer.
-character(*), parameter :: FI4PZP = '(I11.10)' !< Output format for kind=I4P integer with zero prefixing.
-character(*), parameter :: FI2P = '(I6)' !< Output format for kind=I2P integer.
-character(*), parameter :: FI2PZP = '(I6.5)' !< Output format for kind=I2P integer with zero prefixing.
-character(*), parameter :: FI1P = '(I4)' !< Output format for kind=I1P integer.
-character(*), parameter :: FI1PZP = '(I4.3)' !< Output format for kind=I1P integer with zero prefixing.
-character(*), parameter :: FI_P = FI4P !< Output format for kind=I_P integer.
-character(*), parameter :: FI_PZP = FI4PZP !< Output format for kind=I_P integer with zero prefixing.
+CHARACTER(*), PARAMETER :: FI8P = '(I20)' !< Output format for kind=I8P integer.
+CHARACTER(*), PARAMETER :: FI8PZP = '(I20.19)' !< Output format for kind=I8P integer with zero prefixing.
+CHARACTER(*), PARAMETER :: FI4P = '(I11)' !< Output format for kind=I4P integer.
+CHARACTER(*), PARAMETER :: FI4PZP = '(I11.10)' !< Output format for kind=I4P integer with zero prefixing.
+CHARACTER(*), PARAMETER :: FI2P = '(I6)' !< Output format for kind=I2P integer.
+CHARACTER(*), PARAMETER :: FI2PZP = '(I6.5)' !< Output format for kind=I2P integer with zero prefixing.
+CHARACTER(*), PARAMETER :: FI1P = '(I4)' !< Output format for kind=I1P integer.
+CHARACTER(*), PARAMETER :: FI1PZP = '(I4.3)' !< Output format for kind=I1P integer with zero prefixing.
+CHARACTER(*), PARAMETER :: FI_P = FI4P !< Output format for kind=I_P integer.
+CHARACTER(*), PARAMETER :: FI_PZP = FI4PZP !< Output format for kind=I_P integer with zero prefixing.
! length (number of digits) of formatted numbers
#if defined _R16P
-integer, parameter :: DR16P = 42 !< Number of digits of output format FR16P.
+INTEGER, PARAMETER :: DR16P = 42 !< Number of digits of output format FR16P.
#else
-integer, parameter :: DR16P = 23 !< Number of digits of output format FR8P.
+INTEGER, PARAMETER :: DR16P = 23 !< Number of digits of output format FR8P.
#endif
-integer, parameter :: DR8P = 23 !< Number of digits of output format FR8P.
-integer, parameter :: DR4P = 13 !< Number of digits of output format FR4P.
+INTEGER, PARAMETER :: DR8P = 23 !< Number of digits of output format FR8P.
+INTEGER, PARAMETER :: DR4P = 13 !< Number of digits of output format FR4P.
#if defined _R16P
#if defined _R_P_IS_R16P
-integer, parameter :: DR_P = DR16P !< Number of digits of output format FR_P.
+INTEGER, PARAMETER :: DR_P = DR16P !< Number of digits of output format FR_P.
#endif
#endif
#if defined _R_P_IS_R8P
-integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P.
+INTEGER, PARAMETER :: DR_P = DR8P !< Number of digits of output format FR_P.
#elif defined _R_P_IS_R4P
-integer, parameter :: DR_P = DR4P !< Number of digits of output format FR_P.
+INTEGER, PARAMETER :: DR_P = DR4P !< Number of digits of output format FR_P.
#else
-integer, parameter :: DR_P = DR8P !< Number of digits of output format FR_P.
+INTEGER, PARAMETER :: DR_P = DR8P !< Number of digits of output format FR_P.
#endif
-integer, parameter :: DI8P = 20 !< Number of digits of output format I8P.
-integer, parameter :: DI4P = 11 !< Number of digits of output format I4P.
-integer, parameter :: DI2P = 6 !< Number of digits of output format I2P.
-integer, parameter :: DI1P = 4 !< Number of digits of output format I1P.
-integer, parameter :: DI_P = DI4P !< Number of digits of output format I_P.
+INTEGER, PARAMETER :: DI8P = 20 !< Number of digits of output format I8P.
+INTEGER, PARAMETER :: DI4P = 11 !< Number of digits of output format I4P.
+INTEGER, PARAMETER :: DI2P = 6 !< Number of digits of output format I2P.
+INTEGER, PARAMETER :: DI1P = 4 !< Number of digits of output format I1P.
+INTEGER, PARAMETER :: DI_P = DI4P !< Number of digits of output format I_P.
! list of kinds
-integer, parameter :: CHARACTER_KINDS_LIST(1:3) = [ASCII, UCS4, CK] !< List of character kinds.
+INTEGER, PARAMETER :: CHARACTER_KINDS_LIST(1:3) = [ASCII, UCS4, CK] !< List of character kinds.
#if defined _R16P
-integer, parameter :: REAL_KINDS_LIST(1:4) = [R16P, R8P, R4P, R_P] !< List of real kinds.
+INTEGER, PARAMETER :: REAL_KINDS_LIST(1:4) = [R16P, R8P, R4P, R_P] !< List of real kinds.
#else
-integer, parameter :: REAL_KINDS_LIST(1:3) = [R8P, R4P, R_P] !< List of real kinds.
+INTEGER, PARAMETER :: REAL_KINDS_LIST(1:3) = [R8P, R4P, R_P] !< List of real kinds.
#endif
#if defined _R16P
character(*), parameter :: REAL_FORMATS_LIST(1:4) = [FR16P, FR8P, FR4P//' ', FR_P] !< List of real formats.
#else
-character(*), parameter :: REAL_FORMATS_LIST(1:3) = [FR8P, FR4P//' ', FR_P] !< List of real formats.
+CHARACTER(*), PARAMETER :: REAL_FORMATS_LIST(1:3) = [FR8P, FR4P//' ', FR_P] !< List of real formats.
#endif
-integer, parameter :: INTEGER_KINDS_LIST(1:5) = [I8P, I4P, I2P, I1P,I_P] !< List of integer kinds.
+INTEGER, PARAMETER :: INTEGER_KINDS_LIST(1:5) = [I8P, I4P, I2P, I1P, I_P] !< List of integer kinds.
character(*), parameter :: INTEGER_FORMATS_LIST(1:5) = [FI8P, FI4P, FI2P//' ', FI1P//' ', FI_P] !< List of integer formats.
! minimum and maximum (representable) values
#if defined _R16P
-real(R16P), parameter :: MinR16P = -huge(1._R16P) !< Minimum value of kind=R16P real.
-real(R16P), parameter :: MaxR16P = huge(1._R16P) !< Maximum value of kind=R16P real.
-#else
-real(R8P), parameter :: MinR16P = -huge(1._R8P ) !< Minimum value of kind=R8P real.
-real(R8P), parameter :: MaxR16P = huge(1._R8P ) !< Maximum value of kind=R8P real.
-#endif
-real(R8P), parameter :: MinR8P = -huge(1._R8P ) !< Minimum value of kind=R8P real.
-real(R8P), parameter :: MaxR8P = huge(1._R8P ) !< Maximum value of kind=R8P real.
-real(R4P), parameter :: MinR4P = -huge(1._R4P ) !< Minimum value of kind=R4P real.
-real(R4P), parameter :: MaxR4P = huge(1._R4P ) !< Maximum value of kind=R4P real.
-real(R_P), parameter :: MinR_P = -huge(1._R_P ) !< Minimum value of kind=R_P real.
-real(R_P), parameter :: MaxR_P = huge(1._R_P ) !< Maximum value of kind=R_P real.
-integer(I8P), parameter :: MinI8P = -huge(1_I8P) !< Minimum value of kind=I8P integer.
-integer(I4P), parameter :: MinI4P = -huge(1_I4P) !< Minimum value of kind=I4P integer.
-integer(I2P), parameter :: MinI2P = -huge(1_I2P) !< Minimum value of kind=I2P integer.
-integer(I1P), parameter :: MinI1P = -huge(1_I1P) !< Minimum value of kind=I1P integer.
-integer(I_P), parameter :: MinI_P = -huge(1_I_P) !< Minimum value of kind=I_P integer.
-integer(I8P), parameter :: MaxI8P = huge(1_I8P) !< Maximum value of kind=I8P integer.
-integer(I4P), parameter :: MaxI4P = huge(1_I4P) !< Maximum value of kind=I4P integer.
-integer(I2P), parameter :: MaxI2P = huge(1_I2P) !< Maximum value of kind=I2P integer.
-integer(I1P), parameter :: MaxI1P = huge(1_I1P) !< Maximum value of kind=I1P integer.
-integer(I_P), parameter :: MaxI_P = huge(1_I_P) !< Maximum value of kind=I_P integer.
+REAL(R16P), PARAMETER :: MinR16P = -HUGE(1._R16P) !< Minimum value of kind=R16P real.
+REAL(R16P), PARAMETER :: MaxR16P = HUGE(1._R16P) !< Maximum value of kind=R16P real.
+#else
+REAL(R8P), PARAMETER :: MinR16P = -HUGE(1._R8P) !< Minimum value of kind=R8P real.
+REAL(R8P), PARAMETER :: MaxR16P = HUGE(1._R8P) !< Maximum value of kind=R8P real.
+#endif
+REAL(R8P), PARAMETER :: MinR8P = -HUGE(1._R8P) !< Minimum value of kind=R8P real.
+REAL(R8P), PARAMETER :: MaxR8P = HUGE(1._R8P) !< Maximum value of kind=R8P real.
+REAL(R4P), PARAMETER :: MinR4P = -HUGE(1._R4P) !< Minimum value of kind=R4P real.
+REAL(R4P), PARAMETER :: MaxR4P = HUGE(1._R4P) !< Maximum value of kind=R4P real.
+REAL(R_P), PARAMETER :: MinR_P = -HUGE(1._R_P) !< Minimum value of kind=R_P real.
+REAL(R_P), PARAMETER :: MaxR_P = HUGE(1._R_P) !< Maximum value of kind=R_P real.
+INTEGER(I8P), PARAMETER :: MinI8P = -HUGE(1_I8P) !< Minimum value of kind=I8P integer.
+INTEGER(I4P), PARAMETER :: MinI4P = -HUGE(1_I4P) !< Minimum value of kind=I4P integer.
+INTEGER(I2P), PARAMETER :: MinI2P = -HUGE(1_I2P) !< Minimum value of kind=I2P integer.
+INTEGER(I1P), PARAMETER :: MinI1P = -HUGE(1_I1P) !< Minimum value of kind=I1P integer.
+INTEGER(I_P), PARAMETER :: MinI_P = -HUGE(1_I_P) !< Minimum value of kind=I_P integer.
+INTEGER(I8P), PARAMETER :: MaxI8P = HUGE(1_I8P) !< Maximum value of kind=I8P integer.
+INTEGER(I4P), PARAMETER :: MaxI4P = HUGE(1_I4P) !< Maximum value of kind=I4P integer.
+INTEGER(I2P), PARAMETER :: MaxI2P = HUGE(1_I2P) !< Maximum value of kind=I2P integer.
+INTEGER(I1P), PARAMETER :: MaxI1P = HUGE(1_I1P) !< Maximum value of kind=I1P integer.
+INTEGER(I_P), PARAMETER :: MaxI_P = HUGE(1_I_P) !< Maximum value of kind=I_P integer.
! real smallest (representable) values
#if defined _R16P
-real(R16P), parameter :: smallR16P = tiny(1._R16P) !< Smallest representable value of kind=R16P real.
+REAL(R16P), PARAMETER :: smallR16P = TINY(1._R16P) !< Smallest representable value of kind=R16P real.
#else
-real(R8P), parameter :: smallR16P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real.
+REAL(R8P), PARAMETER :: smallR16P = TINY(1._R8P) !< Smallest representable value of kind=R8P real.
#endif
-real(R8P), parameter :: smallR8P = tiny(1._R8P ) !< Smallest representable value of kind=R8P real.
-real(R4P), parameter :: smallR4P = tiny(1._R4P ) !< Smallest representable value of kind=R4P real.
-real(R_P), parameter :: smallR_P = tiny(1._R_P ) !< Smallest representable value of kind=R_P real.
+REAL(R8P), PARAMETER :: smallR8P = TINY(1._R8P) !< Smallest representable value of kind=R8P real.
+REAL(R4P), PARAMETER :: smallR4P = TINY(1._R4P) !< Smallest representable value of kind=R4P real.
+REAL(R_P), PARAMETER :: smallR_P = TINY(1._R_P) !< Smallest representable value of kind=R_P real.
! smallest real representable difference by the running calculator
#if defined _R16P
-real(R16P), parameter :: ZeroR16P = nearest(1._R16P, 1._R16P) - &
- nearest(1._R16P,-1._R16P) !< Smallest representable difference of kind=R16P real.
-#else
-real(R8P), parameter :: ZeroR16P = 0._R8P !nearest(1._R8P, 1._R8P) - &
- !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real.
-#endif
-real(R8P), parameter :: ZeroR8P = 0._R8P !nearest(1._R8P, 1._R8P) - &
- !nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real.
-real(R4P), parameter :: ZeroR4P = 0._R4P !nearest(1._R4P, 1._R4P) - &
- !nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P real.
-real(R_P), parameter :: ZeroR_P = 0._R_P !nearest(1._R_P, 1._R_P) - &
- !nearest(1._R_P,-1._R_P) !< Smallest representable difference of kind=R_P real.
+REAL(R16P), PARAMETER :: ZeroR16P = NEAREST(1._R16P, 1._R16P) - &
+ NEAREST(1._R16P, -1._R16P) !< Smallest representable difference of kind=R16P real.
+#else
+REAL(R8P), PARAMETER :: ZeroR16P = 0._R8P !nearest(1._R8P, 1._R8P) - &
+!nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real.
+#endif
+REAL(R8P), PARAMETER :: ZeroR8P = 0._R8P !nearest(1._R8P, 1._R8P) - &
+!nearest(1._R8P,-1._R8P) !< Smallest representable difference of kind=R8P real.
+REAL(R4P), PARAMETER :: ZeroR4P = 0._R4P !nearest(1._R4P, 1._R4P) - &
+!nearest(1._R4P,-1._R4P) !< Smallest representable difference of kind=R4P real.
+REAL(R_P), PARAMETER :: ZeroR_P = 0._R_P !nearest(1._R_P, 1._R_P) - &
+!nearest(1._R_P,-1._R_P) !< Smallest representable difference of kind=R_P real.
! bits/bytes memory requirements
#if defined _R16P
-integer(I2P), parameter :: BIR16P = storage_size(MaxR16P) !< Number of bits of kind=R16P real.
+INTEGER(I2P), PARAMETER :: BIR16P = STORAGE_SIZE(MaxR16P) !< Number of bits of kind=R16P real.
#else
-integer(I1P), parameter :: BIR16P = storage_size(MaxR8P) !< Number of bits of kind=R8P real.
+INTEGER(I1P), PARAMETER :: BIR16P = STORAGE_SIZE(MaxR8P) !< Number of bits of kind=R8P real.
#endif
-integer(I1P), parameter :: BIR8P = storage_size(MaxR8P) !< Number of bits of kind=R8P real.
-integer(I1P), parameter :: BIR4P = storage_size(MaxR4P) !< Number of bits of kind=R4P real.
-integer(I1P), parameter :: BIR_P = storage_size(MaxR_P) !< Number of bits of kind=R_P real.
+INTEGER(I1P), PARAMETER :: BIR8P = STORAGE_SIZE(MaxR8P) !< Number of bits of kind=R8P real.
+INTEGER(I1P), PARAMETER :: BIR4P = STORAGE_SIZE(MaxR4P) !< Number of bits of kind=R4P real.
+INTEGER(I1P), PARAMETER :: BIR_P = STORAGE_SIZE(MaxR_P) !< Number of bits of kind=R_P real.
#if defined _R16P
-integer(I2P), parameter :: BYR16P = BIR16P/8_I2P !< Number of bytes of kind=R16P real.
-#else
-integer(I1P), parameter :: BYR16P = BIR8P/8_I1P !< Number of bytes of kind=R8P real.
-#endif
-integer(I1P), parameter :: BYR8P = BIR8P/8_I1P !< Number of bytes of kind=R8P real.
-integer(I1P), parameter :: BYR4P = BIR4P/8_I1P !< Number of bytes of kind=R4P real.
-integer(I1P), parameter :: BYR_P = BIR_P/8_I1P !< Number of bytes of kind=R_P real.
-integer(I8P), parameter :: BII8P = storage_size(MaxI8P) !< Number of bits of kind=I8P integer.
-integer(I4P), parameter :: BII4P = storage_size(MaxI4P) !< Number of bits of kind=I4P integer.
-integer(I2P), parameter :: BII2P = storage_size(MaxI2P) !< Number of bits of kind=I2P integer.
-integer(I1P), parameter :: BII1P = storage_size(MaxI1P) !< Number of bits of kind=I1P integer.
-integer(I_P), parameter :: BII_P = storage_size(MaxI_P) !< Number of bits of kind=I_P integer.
-integer(I8P), parameter :: BYI8P = BII8P/8_I8P !< Number of bytes of kind=I8P integer.
-integer(I4P), parameter :: BYI4P = BII4P/8_I4P !< Number of bytes of kind=I4P integer.
-integer(I2P), parameter :: BYI2P = BII2P/8_I2P !< Number of bytes of kind=I2P integer.
-integer(I1P), parameter :: BYI1P = BII1P/8_I1P !< Number of bytes of kind=I1P integer.
-integer(I_P), parameter :: BYI_P = BII_P/8_I_P !< Number of bytes of kind=I_P integer.
+INTEGER(I2P), PARAMETER :: BYR16P = BIR16P / 8_I2P !< Number of bytes of kind=R16P real.
+#else
+INTEGER(I1P), PARAMETER :: BYR16P = BIR8P / 8_I1P !< Number of bytes of kind=R8P real.
+#endif
+INTEGER(I1P), PARAMETER :: BYR8P = BIR8P / 8_I1P !< Number of bytes of kind=R8P real.
+INTEGER(I1P), PARAMETER :: BYR4P = BIR4P / 8_I1P !< Number of bytes of kind=R4P real.
+INTEGER(I1P), PARAMETER :: BYR_P = BIR_P / 8_I1P !< Number of bytes of kind=R_P real.
+INTEGER(I8P), PARAMETER :: BII8P = STORAGE_SIZE(MaxI8P) !< Number of bits of kind=I8P integer.
+INTEGER(I4P), PARAMETER :: BII4P = STORAGE_SIZE(MaxI4P) !< Number of bits of kind=I4P integer.
+INTEGER(I2P), PARAMETER :: BII2P = STORAGE_SIZE(MaxI2P) !< Number of bits of kind=I2P integer.
+INTEGER(I1P), PARAMETER :: BII1P = STORAGE_SIZE(MaxI1P) !< Number of bits of kind=I1P integer.
+INTEGER(I_P), PARAMETER :: BII_P = STORAGE_SIZE(MaxI_P) !< Number of bits of kind=I_P integer.
+INTEGER(I8P), PARAMETER :: BYI8P = BII8P / 8_I8P !< Number of bytes of kind=I8P integer.
+INTEGER(I4P), PARAMETER :: BYI4P = BII4P / 8_I4P !< Number of bytes of kind=I4P integer.
+INTEGER(I2P), PARAMETER :: BYI2P = BII2P / 8_I2P !< Number of bytes of kind=I2P integer.
+INTEGER(I1P), PARAMETER :: BYI1P = BII1P / 8_I1P !< Number of bytes of kind=I1P integer.
+INTEGER(I_P), PARAMETER :: BYI_P = BII_P / 8_I_P !< Number of bytes of kind=I_P integer.
endmodule penf_global_parameters_variables
diff --git a/src/modules/PENF/src/penf_stringify.F90 b/src/modules/PENF/src/penf_stringify.F90
index 979db78d1..e34edeedc 100644
--- a/src/modules/PENF/src/penf_stringify.F90
+++ b/src/modules/PENF/src/penf_stringify.F90
@@ -20,7 +20,7 @@
! summary: PENF string-to-number (and viceversa) facility.
MODULE PENF_STRINGIFY
-USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: stderr => error_unit
+USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: stderr => ERROR_UNIT
USE PENF_B_SIZE
USE PENF_GLOBAL_PARAMETERS_VARIABLES
IMPLICIT NONE
diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt
index 86560150e..e5c71feed 100644
--- a/src/modules/Polynomial/CMakeLists.txt
+++ b/src/modules/Polynomial/CMakeLists.txt
@@ -1,39 +1,40 @@
-# This program is a part of EASIFEM library
-# Copyright (C) 2020-2021 Vikas Sharma, Ph.D
+# 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 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.
+# 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
+# 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}/InterpolationUtility.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
- ${src_path}/Chebyshev1PolynomialUtility.F90
- ${src_path}/LineInterpolationUtility.F90
- ${src_path}/TriangleInterpolationUtility.F90
- ${src_path}/QuadrangleInterpolationUtility.F90
- ${src_path}/TetrahedronInterpolationUtility.F90
- ${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
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/InterpolationUtility.F90
+ ${src_path}/LagrangePolynomialUtility.F90
+ ${src_path}/HierarchicalPolynomialUtility.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
+ ${src_path}/Chebyshev1PolynomialUtility.F90
+ ${src_path}/LineInterpolationUtility.F90
+ ${src_path}/TriangleInterpolationUtility.F90
+ ${src_path}/QuadrangleInterpolationUtility.F90
+ ${src_path}/TetrahedronInterpolationUtility.F90
+ ${src_path}/HexahedronInterpolationUtility.F90
+ ${src_path}/PrismInterpolationUtility.F90
+ ${src_path}/PyramidInterpolationUtility.F90
+ ${src_path}/RecursiveNodesUtility.F90
+ ${src_path}/PolynomialUtility.F90)
+
diff --git a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90 b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90
index 10bfc0a0c..5e6b35dc3 100644
--- a/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90
+++ b/src/modules/Polynomial/src/Chebyshev1PolynomialUtility.F90
@@ -16,9 +16,12 @@
!
MODULE Chebyshev1PolynomialUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
USE BaseType, ONLY: iface_1DFunction
+
IMPLICIT NONE
+
PUBLIC :: Chebyshev1Alpha
PUBLIC :: Chebyshev1Beta
PUBLIC :: GetChebyshev1RecurrenceCoeff
@@ -41,10 +44,12 @@ MODULE Chebyshev1PolynomialUtility
PUBLIC :: Chebyshev1MonomialExpansionAll
PUBLIC :: Chebyshev1MonomialExpansion
PUBLIC :: Chebyshev1GradientEvalAll
+PUBLIC :: Chebyshev1GradientEvalAll_
PUBLIC :: Chebyshev1GradientEval
PUBLIC :: Chebyshev1EvalSum
PUBLIC :: Chebyshev1GradientEvalSum
PUBLIC :: Chebyshev1Transform
+PUBLIC :: Chebyshev1Transform_
PUBLIC :: Chebyshev1InvTransform
PUBLIC :: Chebyshev1GradientCoeff
PUBLIC :: Chebyshev1DMatrix
@@ -407,7 +412,7 @@ END SUBROUTINE Chebyshev1Quadrature
! date: 6 Sept 2022
! summary: Evaluate Chebyshev1 polynomials of order = n at single x
-INTERFACE
+INTERFACE Chebyshev1Eval
MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -416,10 +421,6 @@ MODULE PURE FUNCTION Chebyshev1Eval1(n, x) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -430,7 +431,7 @@ END FUNCTION Chebyshev1Eval1
! date: 6 Sept 2022
! summary: Evaluate Chebyshev1 polynomials of order n at several points
-INTERFACE
+INTERFACE Chebyshev1Eval
MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -439,10 +440,6 @@ MODULE PURE FUNCTION Chebyshev1Eval2(n, x) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -463,7 +460,7 @@ END FUNCTION Chebyshev1Eval2
!- ans(1:N+1), the values of the first N+1 Chebyshev1 polynomials at the
! point
-INTERFACE
+INTERFACE Chebyshev1EvalAll
MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -473,12 +470,26 @@ MODULE PURE FUNCTION Chebyshev1EvalAll1(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! Chebyshev1EvalAll
+!----------------------------------------------------------------------------
+
+INTERFACE Chebyshev1EvalAll_
+ MODULE PURE SUBROUTINE Chebyshev1EvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: x
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ ! ans(n + 1)
+ !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE Chebyshev1EvalAll1_
+END INTERFACE Chebyshev1EvalAll_
+
!----------------------------------------------------------------------------
! Chebyshev1EvalAll
!----------------------------------------------------------------------------
@@ -498,7 +509,7 @@ END FUNCTION Chebyshev1EvalAll1
!- ans(M,1:N+1), the values of the first N+1 Chebyshev1 polynomials at the
! points x(1:m)
-INTERFACE
+INTERFACE Chebyshev1EvalAll
MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -508,12 +519,26 @@ MODULE PURE FUNCTION Chebyshev1EvalAll2(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! ChebyshevEvalAll2_
+!----------------------------------------------------------------------------
+
+INTERFACE Chebyshev1EvalAll_
+ MODULE PURE SUBROUTINE Chebyshev1EvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! several points of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), n + 1)
+ !! Evaluate Chebyshev1 polynomial of order = 0 to n (total n+1)
+ !! at points x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Chebyshev1EvalAll2_
+END INTERFACE Chebyshev1EvalAll_
+
!----------------------------------------------------------------------------
! Chebyshev1MonomialExpansionAll
!----------------------------------------------------------------------------
@@ -582,22 +607,32 @@ END FUNCTION Chebyshev1MonomialExpansion
!
! Evaluate gradient of Chebyshev1 polynomial of order upto n.
-INTERFACE
+INTERFACE Chebyshev1GradientEvalAll
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
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+INTERFACE Chebyshev1GradientEvalAll_
+ MODULE PURE SUBROUTINE Chebyshev1GradientEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! ans(1:n + 1)
+ END SUBROUTINE Chebyshev1GradientEvalAll1_
+END INTERFACE Chebyshev1GradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n
@@ -606,22 +641,32 @@ END FUNCTION Chebyshev1GradientEvalAll1
!
! Evaluate gradient of Chebyshev1 polynomial of order upto n.
-INTERFACE
+INTERFACE Chebyshev1GradientEvalAll
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
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+INTERFACE Chebyshev1GradientEvalAll_
+ MODULE PURE SUBROUTINE Chebyshev1GradientEvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(1:SIZE(x), 1:n + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Chebyshev1GradientEvalAll2_
+END INTERFACE Chebyshev1GradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of Chebyshev1 polynomial of order upto n
@@ -630,17 +675,12 @@ END FUNCTION Chebyshev1GradientEvalAll2
!
! Evaluate gradient of Chebyshev1 polynomial of order upto n.
-INTERFACE
+INTERFACE Chebyshev1GradientEval
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
!----------------------------------------------------------------------------
@@ -655,16 +695,12 @@ END FUNCTION Chebyshev1GradientEval1
!
! Evaluate gradient of Chebyshev1 polynomial of order upto n.
-INTERFACE
+INTERFACE Chebyshev1GradientEval
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
!----------------------------------------------------------------------------
@@ -675,7 +711,7 @@ END FUNCTION Chebyshev1GradientEval2
! date: 6 Sept 2022
! summary: Evaluate finite sum of Chebyshev1 polynomials at point x
-INTERFACE
+INTERFACE Chebyshev1EvalSum
MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -687,10 +723,6 @@ MODULE PURE FUNCTION Chebyshev1EvalSum1(n, x, coeff) &
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
!----------------------------------------------------------------------------
@@ -701,7 +733,7 @@ END FUNCTION Chebyshev1EvalSum1
! date: 6 Sept 2022
! summary: Evaluate finite sum of Chebyshev1 polynomials at several x
-INTERFACE
+INTERFACE Chebyshev1EvalSum
MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -712,10 +744,6 @@ MODULE PURE FUNCTION Chebyshev1EvalSum2(n, x, coeff) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -727,7 +755,7 @@ END FUNCTION Chebyshev1EvalSum2
! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials
! at point x
-INTERFACE
+INTERFACE Chebyshev1GradientEvalSum
MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -738,10 +766,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum1(n, x, coeff) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -753,7 +777,7 @@ END FUNCTION Chebyshev1GradientEvalSum1
! summary: Evaluate the gradient of finite sum of Chebyshev1 polynomials
! at several x
-INTERFACE
+INTERFACE Chebyshev1GradientEvalSum
MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -765,10 +789,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum2(n, x, coeff) &
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
!----------------------------------------------------------------------------
@@ -780,7 +800,7 @@ END FUNCTION Chebyshev1GradientEvalSum2
! summary: Evaluate the kth derivative of finite sum of Chebyshev1
! polynomials at point x
-INTERFACE
+INTERFACE Chebyshev1GradientEvalSum
MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -793,10 +813,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum3(n, x, coeff, k) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -808,7 +824,7 @@ END FUNCTION Chebyshev1GradientEvalSum3
! summary: Evaluate the kth gradient of finite sum of Chebyshev1
! polynomials at several x
-INTERFACE
+INTERFACE Chebyshev1GradientEvalSum
MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -821,10 +837,6 @@ MODULE PURE FUNCTION Chebyshev1GradientEvalSum4(n, x, coeff, k) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -835,7 +847,7 @@ END FUNCTION Chebyshev1GradientEvalSum4
! date: 13 Oct 2022
! summary: Discrete Chebyshev1 Transform
-INTERFACE
+INTERFACE Chebyshev1Transform
MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, &
& quadType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -852,42 +864,63 @@ MODULE PURE FUNCTION Chebyshev1Transform1(n, coeff, x, w, &
REAL(DFP) :: ans(0:n)
!! modal values or coefficients
END FUNCTION Chebyshev1Transform1
-END INTERFACE
-
-INTERFACE Chebyshev1Transform
- MODULE PROCEDURE Chebyshev1Transform1
END INTERFACE Chebyshev1Transform
!----------------------------------------------------------------------------
-! Chebyshev1Transform
+! Chebyshev1Transform
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 13 Oct 2022
-! summary: Columnwise Discrete Chebyshev1 Transform
+! date: 2024-08-19
+! summary: Discrete Chebyshev1 Transform
-INTERFACE
- MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, x, w, &
- & quadType) RESULT(ans)
+INTERFACE Chebyshev1Transform_
+ MODULE PURE SUBROUTINE Chebyshev1Transform1_(n, coeff, x, w, &
+ quadType, ans, tsize)
INTEGER(I4B), INTENT(IN) :: n
- !! order of polynomial
- REAL(DFP), INTENT(IN) :: coeff(0:, 1:)
+ !! order of jacobi polynomial
+ REAL(DFP), INTENT(IN) :: coeff(0:)
!! nodal value (at quad points)
- REAL(DFP), INTENT(IN) :: x(0:n)
+ REAL(DFP), INTENT(IN) :: x(0:)
!! quadrature points
- REAL(DFP), INTENT(IN) :: w(0:n)
+ REAL(DFP), INTENT(IN) :: w(0:)
!! 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
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! ans(0:n)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! tsize = n+1
+ END SUBROUTINE Chebyshev1Transform1_
+END INTERFACE Chebyshev1Transform_
-INTERFACE Chebyshev1Transform
- MODULE PROCEDURE Chebyshev1Transform2
-END INTERFACE Chebyshev1Transform
+!----------------------------------------------------------------------------
+! Chebyshev1Transform
+!----------------------------------------------------------------------------
+
+INTERFACE Chebyshev1Transform_
+ MODULE PURE SUBROUTINE Chebyshev1Transform4_(n, coeff, PP, w, &
+ quadType, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! order of jacobi polynomial
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! nodal value (at quad points)
+ REAL(DFP), INTENT(IN) :: PP(0:, 0:)
+ !! quadrature points
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! weights
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
+ !! GaussRadauRight
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! ans(0:n)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! tsize = n+1
+ END SUBROUTINE Chebyshev1Transform4_
+END INTERFACE Chebyshev1Transform_
!----------------------------------------------------------------------------
! Chebyshev1Transform
@@ -917,9 +950,8 @@ END FUNCTION Chebyshev1Transform2
! `Chebyshev1Quadrature` which is not pure due to Lapack call.
!@endnote
-INTERFACE
- MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) &
- & RESULT(ans)
+INTERFACE Chebyshev1Transform
+ MODULE FUNCTION Chebyshev1Transform3(n, f, quadType, x1, x2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial
PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f
@@ -927,15 +959,39 @@ MODULE FUNCTION Chebyshev1Transform3(n, f, quadType) &
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
!! GaussRadauRight
+ REAL(DFP), INTENT(IN) :: x1, x2
+ !! x1, x2 are the end points of the interval
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: 2024-08-19
+! summary: Chebyshev1 Transform of a function on [-1,1]
+
+INTERFACE Chebyshev1Transform_
+ MODULE SUBROUTINE Chebyshev1Transform3_(n, f, quadType, x1, x2, ans, tsize)
+ 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), INTENT(IN) :: x1, x2
+ !! x1, x2 are the end points of the interval
+ REAL(DFP) :: ans(0:)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! tsize = n+1
+ END SUBROUTINE Chebyshev1Transform3_
+END INTERFACE Chebyshev1Transform_
+
!----------------------------------------------------------------------------
! Chebyshev1Transform
!----------------------------------------------------------------------------
@@ -948,19 +1004,45 @@ END FUNCTION Chebyshev1Transform3
! Discrete Chebyshev transform. We calculate weights and quadrature points
! internally.
-INTERFACE
- MODULE PURE FUNCTION Chebyshev1Transform4(n, coeff, quadType) RESULT(ans)
+INTERFACE Chebyshev1Transform
+ MODULE PURE FUNCTION Chebyshev1Transform2(n, coeff, quadType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial
- REAL(DFP), INTENT(IN) :: coeff(0:n)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
!! nodal value (at quad points)
+ !! size if quadrature 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
+ END FUNCTION Chebyshev1Transform2
+END INTERFACE Chebyshev1Transform
+
+!----------------------------------------------------------------------------
+! Chebyshev1Transform
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date:
+! summary: Discrete Chebyshev1 Transform
+
+INTERFACE Chebyshev1Transform_
+ MODULE PURE SUBROUTINE Chebyshev1Transform2_(n, coeff, quadType, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! order of jacobi polynomial
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! nodal value (at quad points)
+ !! size is quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
+ !! GaussRadauRight
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! tsize = n+1
+ END SUBROUTINE Chebyshev1Transform2_
+END INTERFACE Chebyshev1Transform_
!----------------------------------------------------------------------------
! Chebyshev1InvTransform
@@ -970,7 +1052,7 @@ END FUNCTION Chebyshev1Transform4
! date: 13 Oct 2022
! summary: Inverse Chebyshev1 Transform
-INTERFACE
+INTERFACE Chebyshev1InvTransform
MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -982,10 +1064,6 @@ MODULE PURE FUNCTION Chebyshev1InvTransform1(n, coeff, x) &
REAL(DFP) :: ans
!! value in physical space
END FUNCTION Chebyshev1InvTransform1
-END INTERFACE
-
-INTERFACE Chebyshev1InvTransform
- MODULE PROCEDURE Chebyshev1InvTransform1
END INTERFACE Chebyshev1InvTransform
!----------------------------------------------------------------------------
@@ -996,7 +1074,7 @@ END FUNCTION Chebyshev1InvTransform1
! date: 13 Oct 2022
! summary: Inverse Chebyshev1 Transform
-INTERFACE
+INTERFACE Chebyshev1InvTransform
MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -1008,10 +1086,6 @@ MODULE PURE FUNCTION Chebyshev1InvTransform2(n, coeff, x) &
REAL(DFP) :: ans(SIZE(x))
!! value in physical space
END FUNCTION Chebyshev1InvTransform2
-END INTERFACE
-
-INTERFACE Chebyshev1InvTransform
- MODULE PROCEDURE Chebyshev1InvTransform2
END INTERFACE Chebyshev1InvTransform
!----------------------------------------------------------------------------
@@ -1028,7 +1102,7 @@ END FUNCTION Chebyshev1InvTransform2
!- Input is coefficient of Chebyshev1 expansion (modal values)
!- Output is coefficient of derivative of Chebyshev1 expansion (modal values)
-INTERFACE
+INTERFACE Chebyshev1GradientCoeff
MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -1038,10 +1112,6 @@ MODULE PURE FUNCTION Chebyshev1GradientCoeff1(n, coeff) &
REAL(DFP) :: ans(0:n)
!! coefficient of gradient
END FUNCTION Chebyshev1GradientCoeff1
-END INTERFACE
-
-INTERFACE Chebyshev1GradientCoeff
- MODULE PROCEDURE Chebyshev1GradientCoeff1
END INTERFACE Chebyshev1GradientCoeff
!----------------------------------------------------------------------------
@@ -1052,7 +1122,7 @@ END FUNCTION Chebyshev1GradientCoeff1
! date: 15 Oct 2022
! summary: Returns differentiation matrix for Chebyshev1 expansion
-INTERFACE
+INTERFACE Chebyshev1DMatrix
MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -1064,10 +1134,6 @@ MODULE PURE FUNCTION Chebyshev1DMatrix1(n, x, quadType) &
REAL(DFP) :: ans(0:n, 0:n)
!! D matrix
END FUNCTION Chebyshev1DMatrix1
-END INTERFACE
-
-INTERFACE Chebyshev1DMatrix
- MODULE PROCEDURE Chebyshev1DMatrix1
END INTERFACE Chebyshev1DMatrix
!----------------------------------------------------------------------------
@@ -1078,7 +1144,7 @@ END FUNCTION Chebyshev1DMatrix1
! date: 15 Oct 2022
! summary: Performs even and odd decomposition of Differential matrix
-INTERFACE
+INTERFACE Chebyshev1DMatEvenOdd
MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o)
INTEGER(I4B), INTENT(IN) :: n
!! order of Chebyshev1 polynomial
@@ -1089,10 +1155,6 @@ MODULE PURE SUBROUTINE Chebyshev1DMatEvenOdd1(n, D, e, o)
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
END MODULE Chebyshev1PolynomialUtility
diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90
index fef9276e3..cc4adabad 100644
--- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90
@@ -18,20 +18,26 @@
MODULE HexahedronInterpolationUtility
USE GlobalData
USE String_Class, ONLY: String
+
IMPLICIT NONE
PRIVATE
PUBLIC :: LagrangeDegree_Hexahedron
PUBLIC :: LagrangeDOF_Hexahedron
PUBLIC :: LagrangeInDOF_Hexahedron
PUBLIC :: EquidistancePoint_Hexahedron
+PUBLIC :: EquidistancePoint_Hexahedron_
PUBLIC :: EquidistanceInPoint_Hexahedron
PUBLIC :: InterpolationPoint_Hexahedron
+PUBLIC :: InterpolationPoint_Hexahedron_
PUBLIC :: LagrangeCoeff_Hexahedron
+PUBLIC :: LagrangeCoeff_Hexahedron_
PUBLIC :: EdgeConnectivity_Hexahedron
PUBLIC :: FacetConnectivity_Hexahedron
-PUBLIC :: QuadratureNumber_Hexahedron
PUBLIC :: TensorProdBasis_Hexahedron
+
PUBLIC :: OrthogonalBasis_Hexahedron
+PUBLIC :: OrthogonalBasis_Hexahedron_
+
PUBLIC :: VertexBasis_Hexahedron
PUBLIC :: xEdgeBasis_Hexahedron
PUBLIC :: yEdgeBasis_Hexahedron
@@ -42,18 +48,32 @@ MODULE HexahedronInterpolationUtility
PUBLIC :: xzFacetBasis_Hexahedron
PUBLIC :: FacetBasis_Hexahedron
PUBLIC :: CellBasis_Hexahedron
+
PUBLIC :: HeirarchicalBasis_Hexahedron
+PUBLIC :: HeirarchicalBasis_Hexahedron_
+
+PUBLIC :: QuadratureNumber_Hexahedron
PUBLIC :: QuadraturePoint_Hexahedron
+PUBLIC :: QuadraturePoint_Hexahedron_
+
PUBLIC :: LagrangeEvalAll_Hexahedron
+PUBLIC :: LagrangeEvalAll_Hexahedron_
PUBLIC :: GetVertexDOF_Hexahedron
PUBLIC :: GetEdgeDOF_Hexahedron
PUBLIC :: GetFacetDOF_Hexahedron
PUBLIC :: GetCellDOF_Hexahedron
PUBLIC :: RefElemDomain_Hexahedron
PUBLIC :: LagrangeGradientEvalAll_Hexahedron
+PUBLIC :: LagrangeGradientEvalAll_Hexahedron_
+
PUBLIC :: OrthogonalBasisGradient_Hexahedron
+PUBLIC :: OrthogonalBasisGradient_Hexahedron_
+
PUBLIC :: TensorProdBasisGradient_Hexahedron
+
PUBLIC :: HeirarchicalBasisGradient_Hexahedron
+PUBLIC :: HeirarchicalBasisGradient_Hexahedron_
+
PUBLIC :: GetTotalDOF_Hexahedron
PUBLIC :: GetTotalInDOF_Hexahedron
@@ -91,15 +111,30 @@ END FUNCTION GetTotalDOF_Hexahedron
! lagrange polynomial on an edge of a Hexahedron
!- These dof are strictly inside the Hexahedron
-INTERFACE
- MODULE PURE FUNCTION GetTotalInDOF_Hexahedron(order, baseContinuity, &
+INTERFACE GetTotalInDOF_Hexahedron
+ MODULE PURE FUNCTION GetTotalInDOF_Hexahedron1(order, baseContinuity, &
baseInterpolation) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
CHARACTER(*), INTENT(IN) :: baseContinuity
CHARACTER(*), INTENT(IN) :: baseInterpolation
INTEGER(I4B) :: ans
- END FUNCTION GetTotalInDOF_Hexahedron
-END INTERFACE
+ END FUNCTION GetTotalInDOF_Hexahedron1
+END INTERFACE GetTotalInDOF_Hexahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE GetTotalInDOF_Hexahedron
+ MODULE PURE FUNCTION GetTotalInDOF_Hexahedron2(p, q, r, baseContinuity, &
+ baseInterpolation) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: p, q, r
+ !! order in x, y and z direction
+ CHARACTER(*), INTENT(IN) :: baseContinuity
+ CHARACTER(*), INTENT(IN) :: baseInterpolation
+ INTEGER(I4B) :: ans
+ END FUNCTION GetTotalInDOF_Hexahedron2
+END INTERFACE GetTotalInDOF_Hexahedron
!----------------------------------------------------------------------------
! RefElemDomain_Hexahedron
@@ -325,13 +360,8 @@ END FUNCTION GetCellDOF_Hexahedron2
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE FUNCTION QuadratureNumber_Hexahedron( &
- & p, &
- & q, &
- & r, &
- & quadType1, &
- & quadType2, &
- & quadType3) RESULT(ans)
+ MODULE PURE FUNCTION QuadratureNumber_Hexahedron(p, q, r, quadType1, &
+ quadType2, quadType3) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p, q, r
INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3
INTEGER(I4B) :: ans(3)
@@ -347,9 +377,8 @@ END FUNCTION QuadratureNumber_Hexahedron
! summary: This function returns the edge connectivity of Hexahedron
INTERFACE
- MODULE PURE FUNCTION FacetConnectivity_Hexahedron( &
- & baseInterpol, &
- & baseContinuity) RESULT(ans)
+ MODULE PURE FUNCTION FacetConnectivity_Hexahedron(baseInterpol, &
+ baseContinuity) RESULT(ans)
CHARACTER(*), INTENT(IN) :: baseInterpol
CHARACTER(*), INTENT(IN) :: baseContinuity
INTEGER(I4B) :: ans(4, 6)
@@ -365,9 +394,8 @@ END FUNCTION FacetConnectivity_Hexahedron
! summary: This function returns the edge connectivity of Hexahedron
INTERFACE
- MODULE PURE FUNCTION EdgeConnectivity_Hexahedron( &
- & baseInterpol, &
- & baseContinuity) RESULT(ans)
+ MODULE PURE FUNCTION EdgeConnectivity_Hexahedron(baseInterpol, &
+ baseContinuity) RESULT(ans)
CHARACTER(*), INTENT(IN) :: baseInterpol
CHARACTER(*), INTENT(IN) :: baseContinuity
INTEGER(I4B) :: ans(2, 12)
@@ -563,6 +591,24 @@ MODULE PURE FUNCTION EquidistancePoint_Hexahedron1(order, xij) RESULT(ans)
END FUNCTION EquidistancePoint_Hexahedron1
END INTERFACE EquidistancePoint_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistancePoint_Hexahedron_
+ MODULE PURE SUBROUTINE EquidistancePoint_Hexahedron1_(order, ans, nrow, &
+ ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! number of rows = 3
+ !! number of cols = 8
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE EquidistancePoint_Hexahedron1_
+END INTERFACE EquidistancePoint_Hexahedron_
+
!----------------------------------------------------------------------------
! EquidistancePoint_Hexahedron
!----------------------------------------------------------------------------
@@ -597,6 +643,28 @@ MODULE PURE FUNCTION EquidistancePoint_Hexahedron2(p, q, r, xij) &
END FUNCTION EquidistancePoint_Hexahedron2
END INTERFACE EquidistancePoint_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistancePoint_Hexahedron_
+ MODULE PURE SUBROUTINE EquidistancePoint_Hexahedron2_(p, q, r, ans, nrow, &
+ ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order in y direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! order in z direction
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! number of rows = 3
+ !! number of cols = 8
+ END SUBROUTINE EquidistancePoint_Hexahedron2_
+END INTERFACE EquidistancePoint_Hexahedron_
+
!----------------------------------------------------------------------------
! InterpolationPoint_Hexahedron
!----------------------------------------------------------------------------
@@ -607,7 +675,7 @@ END FUNCTION EquidistancePoint_Hexahedron2
INTERFACE InterpolationPoint_Hexahedron
MODULE FUNCTION InterpolationPoint_Hexahedron1(order, ipType, &
- & layout, xij, alpha, beta, lambda) RESULT(ans)
+ layout, xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order in x, y and z direction
INTEGER(I4B), INTENT(IN) :: ipType
@@ -636,23 +704,49 @@ END FUNCTION InterpolationPoint_Hexahedron1
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-10
-! summary: Interpolation points
+! date: 2024-06-26
+! summary: Interpolation points without allocation
+
+INTERFACE InterpolationPoint_Hexahedron_
+ MODULE SUBROUTINE InterpolationPoint_Hexahedron1_(order, ipType, ans, &
+ nrow, ncol, layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order in x, y and z direction
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Interpolation type in x, y, and z direction
+ !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev,
+ !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in xij format
+ !! rows of ans denotes x, y, z components
+ !! cols of ans denotes x, y, z components
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and cols
+ CHARACTER(*), INTENT(IN) :: layout
+ !! layout can be VEFC or INCREASING
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordiantes of reference hexahedron
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE InterpolationPoint_Hexahedron1_
+END INTERFACE InterpolationPoint_Hexahedron_
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Hexahedron
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-26
+! summary: Interpolation points hexahedron
INTERFACE InterpolationPoint_Hexahedron
- MODULE FUNCTION InterpolationPoint_Hexahedron2( &
- & p, &
- & q, &
- & r, &
- & ipType1, &
- & ipType2, &
- & ipType3, &
- & layout, &
- & xij, &
- & alpha1, beta1, lambda1, &
- & alpha2, beta2, lambda2, &
- & alpha3, beta3, lambda3 &
- & ) RESULT(ans)
+ MODULE FUNCTION InterpolationPoint_Hexahedron2(p, q, r, ipType1, &
+ ipType2, ipType3, layout, xij, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order in x direction
INTEGER(I4B), INTENT(IN) :: q
@@ -694,6 +788,61 @@ MODULE FUNCTION InterpolationPoint_Hexahedron2( &
END FUNCTION InterpolationPoint_Hexahedron2
END INTERFACE InterpolationPoint_Hexahedron
+!----------------------------------------------------------------------------
+! InterpolationPoint_Hexahedron
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-10
+! summary: Interpolation points
+
+INTERFACE InterpolationPoint_Hexahedron_
+ MODULE SUBROUTINE InterpolationPoint_Hexahedron2_(p, q, r, ipType1, &
+ ipType2, ipType3, ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, alpha3, beta3, lambda3)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order in y direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! order in z direction
+ INTEGER(I4B), INTENT(IN) :: ipType1
+ !! interpolation type in x direction
+ INTEGER(I4B), INTENT(IN) :: ipType2
+ !! interpolation type in y direction
+ INTEGER(I4B), INTENT(IN) :: ipType3
+ !! interpolation type in z direction
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolation points in xij format
+ !! rows of ans denotes x, y, z components
+ !! cols of ans denotes x, y, z components
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and cols written in ans
+ CHARACTER(*), INTENT(IN) :: layout
+ !! layout can be VEFC or INCREASING
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinate of reference Hexahedron
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta3
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3
+ !! Ultraspherical parameter
+ END SUBROUTINE InterpolationPoint_Hexahedron2_
+END INTERFACE InterpolationPoint_Hexahedron_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -703,12 +852,8 @@ END FUNCTION InterpolationPoint_Hexahedron2
! summary: Convert IJK to VEFC format
INTERFACE
- MODULE RECURSIVE PURE SUBROUTINE IJK2VEFC_Hexahedron( &
- & xi, &
- & eta, &
- & zeta, &
- & temp, &
- & p, q, r)
+ MODULE RECURSIVE PURE SUBROUTINE IJK2VEFC_Hexahedron(xi, eta, zeta, &
+ temp, p, q, r)
REAL(DFP), INTENT(IN) :: xi(:, :, :)
REAL(DFP), INTENT(IN) :: eta(:, :, :)
REAL(DFP), INTENT(IN) :: zeta(:, :, :)
@@ -742,6 +887,27 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron1(order, i, xij) RESULT(ans)
END FUNCTION LagrangeCoeff_Hexahedron1
END INTERFACE LagrangeCoeff_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Hexahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Hexahedron1_(order, i, xij, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ INTEGER(I4B), INTENT(IN) :: i
+ !! ith coefficients for lagrange polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! interpolation points in xij format
+ !! number of rows in xij is 3
+ !! number of columns should be equal to the number degree of freedom
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Hexahedron1_
+END INTERFACE LagrangeCoeff_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Hexahedron
!----------------------------------------------------------------------------
@@ -752,7 +918,7 @@ END FUNCTION LagrangeCoeff_Hexahedron1
INTERFACE LagrangeCoeff_Hexahedron
MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial, it should be SIZE(v,2)-1
INTEGER(I4B), INTENT(IN) :: i
@@ -766,6 +932,28 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron2(order, i, v, isVandermonde) &
END FUNCTION LagrangeCoeff_Hexahedron2
END INTERFACE LagrangeCoeff_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Hexahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Hexahedron2_(order, i, v, isVandermonde, &
+ ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Hexahedron2_
+END INTERFACE LagrangeCoeff_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Hexahedron
!----------------------------------------------------------------------------
@@ -789,6 +977,27 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron3(order, i, v, ipiv) RESULT(ans)
END FUNCTION LagrangeCoeff_Hexahedron3
END INTERFACE LagrangeCoeff_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Hexahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Hexahedron3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ ! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Hexahedron3_
+END INTERFACE LagrangeCoeff_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Hexahedron
!----------------------------------------------------------------------------
@@ -799,7 +1008,7 @@ END FUNCTION LagrangeCoeff_Hexahedron3
INTERFACE LagrangeCoeff_Hexahedron
MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij, basisType, &
- & refHexahedron, alpha, beta, lambda) RESULT(ans)
+ refHexahedron, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -825,6 +1034,35 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron4(order, xij, basisType, &
END FUNCTION LagrangeCoeff_Hexahedron4
END INTERFACE LagrangeCoeff_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Hexahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Hexahedron4_(order, xij, basisType, &
+ refHexahedron, alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials, Jacobi, Legendre, Chebyshev, Ultraspherical, Heirarchical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron
+ !! UNIT
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! This parameter is needed when basisType is Ultraspherical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Hexahedron4_
+END INTERFACE LagrangeCoeff_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Hexahedron
!----------------------------------------------------------------------------
@@ -834,25 +1072,57 @@ END FUNCTION LagrangeCoeff_Hexahedron4
! summary: Returns the coefficients of monomials for all lagrange polynomial
INTERFACE LagrangeCoeff_Hexahedron
- MODULE FUNCTION LagrangeCoeff_Hexahedron5(&
- & p, &
- & q, &
- & r, &
- & xij, &
- & basisType1, &
- & basisType2, &
- & basisType3, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2, &
- & alpha3, &
- & beta3, &
- & lambda3, &
- & refHexahedron &
- & ) RESULT(ans)
+ MODULE FUNCTION LagrangeCoeff_Hexahedron5(p, q, r, xij, basisType1, &
+ basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3, refHexahedron) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order of polynomial in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order of polynomial in y direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! order of polynomial in z direction
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! These are interpolation points in xij format, size(xij,2)
+ INTEGER(I4B), INTENT(IN) :: basisType1
+ !! basis type in x direction
+ INTEGER(I4B), INTENT(IN) :: basisType2
+ !! basis type in y direction
+ INTEGER(I4B), INTENT(IN) :: basisType3
+ !! basis type in z direction
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! This parameter is needed when basisType1 is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! This parameter is needed when basisType1 is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! This parameter is needed when basisType1 is Ultraspherical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! This parameter is needed when basisType2 is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! This parameter is needed when basisType2 is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! This parameter is needed when basisType2 is Ultraspherical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3
+ !! This parameter is needed when basisType3 is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta3
+ !! This parameter is needed when basisType3 is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3
+ !! This parameter is needed when basisType3 is Ultraspherical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron
+ !! UNIT
+ !! BIUNIT
+ REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ END FUNCTION LagrangeCoeff_Hexahedron5
+END INTERFACE LagrangeCoeff_Hexahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Hexahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Hexahedron5_(p, q, r, xij, basisType1, &
+ basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3, refHexahedron, ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: p
!! order of polynomial in x direction
INTEGER(I4B), INTENT(IN) :: q
@@ -906,10 +1176,12 @@ MODULE FUNCTION LagrangeCoeff_Hexahedron5(&
CHARACTER(*), OPTIONAL, INTENT(IN) :: refHexahedron
!! UNIT
!! BIUNIT
- REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2))
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(xij, 2), SIZE(xij, 2))
!! coefficients
- END FUNCTION LagrangeCoeff_Hexahedron5
-END INTERFACE LagrangeCoeff_Hexahedron
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Hexahedron5_
+END INTERFACE LagrangeCoeff_Hexahedron_
!----------------------------------------------------------------------------
! TensorProdBasis_Hexahedron
@@ -920,24 +1192,9 @@ END FUNCTION LagrangeCoeff_Hexahedron5
! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron
INTERFACE TensorProdBasis_Hexahedron
- MODULE FUNCTION TensorProdBasis_Hexahedron1( &
- & p, &
- & q, &
- & r, &
- & xij, &
- & basisType1, &
- & basisType2, &
- & basisType3, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2, &
- & alpha3, &
- & beta3, &
- & lambda3) &
- & RESULT(ans)
+ MODULE FUNCTION TensorProdBasis_Hexahedron1(p, q, r, xij, basisType1, &
+ basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! highest order in x1 direction
INTEGER(I4B), INTENT(IN) :: q
@@ -982,55 +1239,88 @@ END FUNCTION TensorProdBasis_Hexahedron1
END INTERFACE OrthogonalBasis_Hexahedron
!----------------------------------------------------------------------------
-! TensorProdBasis_Hexahedron
+! OrthogonalBasis_Hexahedron_
!----------------------------------------------------------------------------
-!> 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 TensorProdBasis_Hexahedron
- MODULE FUNCTION TensorProdBasis_Hexahedron2( &
- & p, &
- & q, &
- & r, &
- & x, &
- & y, &
- & z, &
- & basisType1, &
- & basisType2, &
- & basisType3, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2, &
- & alpha3, &
- & beta3, &
- & lambda3) &
- & RESULT(ans)
+INTERFACE TensorProdBasis_Hexahedron_
+ MODULE SUBROUTINE TensorProdBasis_Hexahedron1_(p, q, r, xij, basisType1, &
+ basisType2, basisType3, ans, nrow, ncol, &
+ alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3)
INTEGER(I4B), INTENT(IN) :: p
!! highest order in x1 direction
INTEGER(I4B), INTENT(IN) :: q
!! highest order in x2 direction
INTEGER(I4B), INTENT(IN) :: r
!! highest order in x3 direction
- REAL(DFP), INTENT(IN) :: x(:), y(:), z(:)
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3
+ !! basis type in x1 direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Tensor basis
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and cols
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (p + 1) * (q + 1) * (r + 1)
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! alpha1 needed when basisType1 "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! beta1 is needed when basisType1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! lambda1 is needed when basisType1 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! alpha2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! beta2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! lambda2 is needed when basisType2 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3
+ !! alpha3 needed when basisType3 "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta3
+ !! beta3 is needed when basisType3 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3
+ !! lambda3 is needed when basisType3 is "Ultraspherical"
+ !!
+ END SUBROUTINE TensorProdBasis_Hexahedron1_
+END INTERFACE TensorProdBasis_Hexahedron_
+
+INTERFACE OrthogonalBasis_Hexahedron_
+ MODULE PROCEDURE TensorProdBasis_Hexahedron1_
+END INTERFACE OrthogonalBasis_Hexahedron_
+
+!----------------------------------------------------------------------------
+! TensorProdBasis_Hexahedron
+!----------------------------------------------------------------------------
+
+!> 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 TensorProdBasis_Hexahedron
+ MODULE FUNCTION TensorProdBasis_Hexahedron2(p, q, r, x, y, z, basisType1, &
+ basisType2, basisType3, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3) RESULT(ans)
+
+ INTEGER(I4B), INTENT(IN) :: p
+ !! highest order in x1 direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! highest order in x2 direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! highest order in x3 direction
+ REAL(DFP), INTENT(IN) :: x(:), y(:), z(:)
!! points of evaluation in xij format
INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3
!! orthogonal polynomial family in x1 direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2
@@ -1046,6 +1336,54 @@ END FUNCTION TensorProdBasis_Hexahedron2
MODULE PROCEDURE TensorProdBasis_Hexahedron2
END INTERFACE OrthogonalBasis_Hexahedron
+!----------------------------------------------------------------------------
+! OrthogonalBasis_Hexahedron_
+!----------------------------------------------------------------------------
+
+!> 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 TensorProdBasis_Hexahedron_
+ MODULE SUBROUTINE TensorProdBasis_Hexahedron2_(p, q, r, x, &
+ y, z, basisType1, basisType2, basisType3, ans, nrow, ncol, &
+ alpha1, beta1, lambda1, alpha2, beta2, lambda2, &
+ alpha3, beta3, lambda3)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! highest order in x1 direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! highest order in x2 direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! highest order in x3 direction
+ REAL(DFP), INTENT(IN) :: x(:), y(:), z(:)
+ !! points of evaluation in xij format
+ INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3
+ !! orthogonal polynomial family in x1 direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Tensor basis
+ !! The number of rows corresponds to the
+ !! total number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x) * SIZE(y) * SIZE(z)
+ !! ncol = (p + 1) * (q + 1) * (r + 1)
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
+ END SUBROUTINE TensorProdBasis_Hexahedron2_
+END INTERFACE TensorProdBasis_Hexahedron_
+
+INTERFACE OrthogonalBasis_Hexahedron_
+ MODULE PROCEDURE TensorProdBasis_Hexahedron2_
+END INTERFACE OrthogonalBasis_Hexahedron_
+
!----------------------------------------------------------------------------
! VertexBasis_Hexahedron
!----------------------------------------------------------------------------
@@ -2030,15 +2368,9 @@ END FUNCTION CellBasisGradient_Hexahedron2
! summary: Returns the HeirarchicalBasis on Hexahedron
INTERFACE HeirarchicalBasis_Hexahedron
- MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1( &
- & pb1, pb2, pb3, &
- & pxy1, pxy2, &
- & pxz1, pxz2, &
- & pyz1, pyz2, &
- & px1, px2, px3, px4, &
- & py1, py2, py3, py4, &
- & pz1, pz2, pz3, pz4, &
- & xij) RESULT(ans)
+ MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1(pb1, pb2, pb3, pxy1, &
+ pxy2, pxz1, pxz2, pyz1, pyz2, px1, px2, px3, px4, py1, py2, py3, py4, &
+ pz1, pz2, pz3, pz4, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3
!! order of interpolation inside the element in x, y, and z dirs
INTEGER(I4B), INTENT(IN) :: pxy1, pxy2
@@ -2070,6 +2402,44 @@ MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron1( &
END FUNCTION HeirarchicalBasis_Hexahedron1
END INTERFACE HeirarchicalBasis_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Hexahedron_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Hexahedron1_(pb1, pb2, pb3, pxy1, &
+ pxy2, pxz1, pxz2, pyz1, pyz2, px1, px2, px3, px4, py1, py2, py3, py4, &
+ pz1, pz2, pz3, pz4, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3
+ !! order of interpolation inside the element in x, y, and z dirs
+ INTEGER(I4B), INTENT(IN) :: pxy1, pxy2
+ !! order of interpolation on facets parallel to xy plane
+ INTEGER(I4B), INTENT(IN) :: pxz1, pxz2
+ !! order of interpolation on facets parallel to xz plane
+ INTEGER(I4B), INTENT(IN) :: pyz1, pyz2
+ !! order of interpolation on facets parallel to yz plane
+ INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4
+ !! order of interpolation on edges parallel to x-axis
+ INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4
+ !! order of interpolation on edges parallel to y-axis
+ INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4
+ !! order of interpolation on edges parallel to z-axis
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xij, 2)
+ !! ncol = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) &
+ !! + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B &
+ !! + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B &
+ !! + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B &
+ !! + (px1 + px2 + px3 + px4 - 4_I4B) &
+ !! + (py1 + py2 + py3 + py4 - 4_I4B) &
+ !! + (pz1 + pz2 + pz3 + pz4 - 4_I4B) &
+ END SUBROUTINE HeirarchicalBasis_Hexahedron1_
+END INTERFACE HeirarchicalBasis_Hexahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Hexahedron
!----------------------------------------------------------------------------
@@ -2079,9 +2449,7 @@ END FUNCTION HeirarchicalBasis_Hexahedron1
! summary: Returns the HeirarchicalBasis on Hexahedron
INTERFACE HeirarchicalBasis_Hexahedron
- MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2( &
- & p, q, r, &
- & xij) RESULT(ans)
+ MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2(p, q, r, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p, q, r
!! order of interpolation in x, y, and z dirs
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -2101,6 +2469,31 @@ MODULE PURE FUNCTION HeirarchicalBasis_Hexahedron2( &
END FUNCTION HeirarchicalBasis_Hexahedron2
END INTERFACE HeirarchicalBasis_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Hexahedron_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Hexahedron2_(p, q, r, xij, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: p, q, r
+ !! order of interpolation in x, y, and z dirs
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xij, 2)
+ !! ncol = 8_I4B + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) &
+ !! + (p - 1_I4B) * (q - 1_I4B) * 2_I4B &
+ !! + (p - 1_I4B) * (r - 1_I4B) * 2_I4B &
+ !! + (q - 1_I4B) * (r - 1_I4B) * 2_I4B &
+ !! + (4_I4B * p - 4_I4B) &
+ !! + (4_I4B * q - 4_I4B) &
+ !! + (4_I4B * r - 4_I4B) &
+ END SUBROUTINE HeirarchicalBasis_Hexahedron2_
+END INTERFACE HeirarchicalBasis_Hexahedron_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
@@ -2110,38 +2503,21 @@ END FUNCTION HeirarchicalBasis_Hexahedron2
! summary: Returns quadrature points on reference hexahedron
INTERFACE QuadraturePoint_Hexahedron
- MODULE FUNCTION QuadraturePoint_Hexahedron1( &
- & order, &
- & quadType, &
- & refHexahedron, &
- & xij, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Hexahedron1(order, quadType, &
+ refHexahedron, xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of integrand in x, y, and z direction
INTEGER(I4B), INTENT(IN) :: quadType
!! quadrature point type
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft
+ !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto
+ !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight
+ !! GaussUltraspherical ! GaussUltrasphericalLobatto
+ !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight
+ !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft
!! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refHexahedron
- !! Reference hexahedron
- !! UNIT
- !! BIUNIT
+ !! Reference hexahedron ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! nodal coordiantes of hexahedron in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
@@ -2155,20 +2531,49 @@ MODULE FUNCTION QuadraturePoint_Hexahedron1( &
END FUNCTION QuadraturePoint_Hexahedron1
END INTERFACE QuadraturePoint_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Hexahedron_
+ MODULE SUBROUTINE QuadraturePoint_Hexahedron1_(order, quadType, &
+ refHexahedron, xij, alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand in x, y, and z direction
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft
+ !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto
+ !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight
+ !! GaussUltraspherical ! GaussUltrasphericalLobatto
+ !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight
+ !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft
+ !! GaussJacobiRadauRight
+ CHARACTER(*), INTENT(IN) :: refHexahedron
+ !! Reference hexahedron ! UNIT ! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordiantes of hexahedron in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! quadrature points in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ END SUBROUTINE QuadraturePoint_Hexahedron1_
+END INTERFACE QuadraturePoint_Hexahedron_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
INTERFACE QuadraturePoint_Hexahedron
- MODULE FUNCTION QuadraturePoint_Hexahedron2( &
- & p, q, r, &
- & quadType1, quadType2, quadType3, &
- & refHexahedron, &
- & xij, &
- & alpha1, beta1, lambda1, &
- & alpha2, beta2, lambda2, &
- & alpha3, beta3, lambda3 &
- & ) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Hexahedron2(p, q, r, quadType1, &
+ quadType2, quadType3, refHexahedron, xij, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order of integrand in x direction
INTEGER(I4B), INTENT(IN) :: q
@@ -2177,27 +2582,15 @@ MODULE FUNCTION QuadraturePoint_Hexahedron2( &
!! order of integrand in z direction
INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3
!! quadrature point type in x direction
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1
+ !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft
+ !! GaussChebyshev1RadauRight ! GaussUltraspherical
+ !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft
+ !! GaussUltrasphericalRadauRight ! GaussJacobi
+ !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refHexahedron
- !! Reference hexahedron
- !! UNIT
- !! BIUNIT
+ !! Reference hexahedron ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! four vertices of quadrangle in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
@@ -2211,6 +2604,45 @@ MODULE FUNCTION QuadraturePoint_Hexahedron2( &
END FUNCTION QuadraturePoint_Hexahedron2
END INTERFACE QuadraturePoint_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Hexahedron_
+ MODULE SUBROUTINE QuadraturePoint_Hexahedron2_(p, q, r, quadType1, &
+ quadType2, quadType3, refHexahedron, xij, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, alpha3, beta3, lambda3, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order of integrand in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order of integrand in y direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! order of integrand in z direction
+ INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3
+ !! quadrature point type in x direction
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1
+ !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft
+ !! GaussChebyshev1RadauRight ! GaussUltraspherical
+ !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft
+ !! GaussUltrasphericalRadauRight ! GaussJacobi
+ !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight
+ CHARACTER(*), INTENT(IN) :: refHexahedron
+ !! Reference hexahedron ! UNIT ! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! four vertices of quadrangle in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
+ !! Jacobi parameter and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2
+ !! Jacobi parameter and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
+ !! Jacobi parameter and Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE QuadraturePoint_Hexahedron2_
+END INTERFACE QuadraturePoint_Hexahedron_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
@@ -2220,33 +2652,18 @@ END FUNCTION QuadraturePoint_Hexahedron2
! summary: Returns quadrature points on reference quadrangle
INTERFACE QuadraturePoint_Hexahedron
- MODULE FUNCTION QuadraturePoint_Hexahedron3( &
- & nips, &
- & quadType, &
- & refHexahedron, &
- & xij, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Hexahedron3(nips, quadType, &
+ refHexahedron, xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: nips(1)
!! number of integration points in x, y, and z direction
INTEGER(I4B), INTENT(IN) :: quadType
!! interpolation point type
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft
+ !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto
+ !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight
+ !! GaussUltraspherical ! GaussUltrasphericalLobatto
+ !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight
+ !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft
!! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refHexahedron
!! Reference hexahedron
@@ -2265,20 +2682,43 @@ MODULE FUNCTION QuadraturePoint_Hexahedron3( &
END FUNCTION QuadraturePoint_Hexahedron3
END INTERFACE QuadraturePoint_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Hexahedron_
+ MODULE SUBROUTINE QuadraturePoint_Hexahedron3_(nips, quadType, &
+ refHexahedron, xij, alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! number of integration points in x, y, and z direction
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! interpolation point type
+ CHARACTER(*), INTENT(IN) :: refHexahedron
+ !! Reference hexahedron
+ !! UNIT
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! four vertices of quadrangle in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE QuadraturePoint_Hexahedron3_
+END INTERFACE QuadraturePoint_Hexahedron_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
INTERFACE QuadraturePoint_Hexahedron
- MODULE FUNCTION QuadraturePoint_Hexahedron4( &
- & nipsx, nipsy, nipsz, &
- & quadType1, quadType2, quadType3, &
- & refHexahedron, &
- & xij, &
- & alpha1, beta1, lambda1, &
- & alpha2, beta2, lambda2, &
- & alpha3, beta3, lambda3 &
- & ) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Hexahedron4(nipsx, nipsy, nipsz, &
+ quadType1, quadType2, quadType3, refHexahedron, xij, alpha1, beta1, &
+ lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: nipsx(1)
!! order of integrand in x direction
INTEGER(I4B), INTENT(IN) :: nipsy(1)
@@ -2287,27 +2727,16 @@ MODULE FUNCTION QuadraturePoint_Hexahedron4( &
!! order of integrand in z direction
INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3
!! quadrature point type in x, y, and z direction
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev1 ! GaussChebyshev1Lobatto
+ !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight
+ !! GaussUltraspherical ! GaussUltrasphericalLobatto
+ !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight
+ !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft
!! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refHexahedron
- !! Reference hexahedron
- !! UNIT
- !! BIUNIT
+ !! Reference hexahedron ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! four vertices of quadrangle in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
@@ -2321,6 +2750,47 @@ MODULE FUNCTION QuadraturePoint_Hexahedron4( &
END FUNCTION QuadraturePoint_Hexahedron4
END INTERFACE QuadraturePoint_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Hexahedron_
+ MODULE SUBROUTINE QuadraturePoint_Hexahedron4_(nipsx, nipsy, nipsz, &
+ quadType1, quadType2, quadType3, refhexahedron, xij, alpha1, beta1, &
+ lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nipsx(1)
+ !! Order of integrand in x direction
+ INTEGER(I4B), INTENT(IN) :: nipsy(1)
+ !! Order of integrand in y direction
+ INTEGER(I4B), INTENT(IN) :: nipsz(1)
+ !! Order of integrand in z direction
+ INTEGER(I4B), INTENT(IN) :: quadType1, quadType2, quadType3
+ !! Quadrature point type in x, y, and z direction
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev1 ! GaussChebyshev1Lobatto
+ !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight
+ !! GaussUltraspherical ! GaussUltrasphericalLobatto
+ !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight
+ !! GaussJacobi ! GaussJacobiLobatto ! GaussJacobiRadauLeft
+ !! GaussJacobiRadauRight
+ CHARACTER(*), INTENT(IN) :: refhexahedron
+ !! Reference hexahedron ! UNIT ! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! four vertices of quadrangle in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
+ !! Jacobi and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2
+ !! Jacobi and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
+ !! Jacobi and Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! results
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns
+ END SUBROUTINE QuadraturePoint_Hexahedron4_
+END INTERFACE QuadraturePoint_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Hexahedron
!----------------------------------------------------------------------------
@@ -2379,6 +2849,48 @@ MODULE FUNCTION LagrangeEvalAll_Hexahedron1( &
END FUNCTION LagrangeEvalAll_Hexahedron1
END INTERFACE LagrangeEvalAll_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Hexahedron_
+ MODULE SUBROUTINE LagrangeEvalAll_Hexahedron1_(order, x, xij, ans, tsize, coeff, &
+ firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(3)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ !! x(3) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ !! The number of rows in xij is 3
+ !! The number of columns in xij should be equal to total
+ !! degree of freedom
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! ans(SIZE(xij, 2))
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be computed and returned
+ !! by this routine.
+ !! If firstCall is False, then coeff should be given, which will be
+ !! used.
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Hexahedron1_
+END INTERFACE LagrangeEvalAll_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Hexahedron
!----------------------------------------------------------------------------
@@ -2433,6 +2945,45 @@ MODULE FUNCTION LagrangeEvalAll_Hexahedron2( &
END FUNCTION LagrangeEvalAll_Hexahedron2
END INTERFACE LagrangeEvalAll_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Hexahedron_
+ MODULE SUBROUTINE LagrangeEvalAll_Hexahedron2_(order, x, xij, ans, nrow, &
+ ncol, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 Lagrange polynomials at point x
+ !! ans(SIZE(x, 2), SIZE(xij, 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Hexahedron2_
+END INTERFACE LagrangeEvalAll_Hexahedron_
+
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Hexahedron
!----------------------------------------------------------------------------
@@ -2486,6 +3037,44 @@ MODULE FUNCTION LagrangeGradientEvalAll_Hexahedron1( &
END FUNCTION LagrangeGradientEvalAll_Hexahedron1
END INTERFACE LagrangeGradientEvalAll_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeGradientEvalAll_Hexahedron_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Hexahedron1_(order, x, xij, ans, &
+ dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! point of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1, dim2, dim3 = SIZE(x, 2), SIZE(xij, 2), 3
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Hexahedron1_
+END INTERFACE LagrangeGradientEvalAll_Hexahedron_
+
!----------------------------------------------------------------------------
! TensorProdBasisGradient_Hexahedron
!----------------------------------------------------------------------------
@@ -2495,24 +3084,9 @@ END FUNCTION LagrangeGradientEvalAll_Hexahedron1
! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron
INTERFACE TensorProdBasisGradient_Hexahedron
- MODULE FUNCTION TensorProdBasisGradient_Hexahedron1( &
- & p, &
- & q, &
- & r, &
- & xij, &
- & basisType1, &
- & basisType2, &
- & basisType3, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2, &
- & alpha3, &
- & beta3, &
- & lambda3) &
- & RESULT(ans)
+ MODULE FUNCTION TensorProdBasisGradient_Hexahedron1(p, q, r, xij, &
+ basisType1, basisType2, basisType3, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, alpha3, beta3, lambda3) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! highest order in x1 direction
INTEGER(I4B), INTENT(IN) :: q
@@ -2523,11 +3097,7 @@ MODULE FUNCTION TensorProdBasisGradient_Hexahedron1( &
!! points of evaluation in xij format
INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3
!! basis type in x1 direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
!! alpha1 needed when basisType1 "Jacobi"
@@ -2555,6 +3125,62 @@ END FUNCTION TensorProdBasisGradient_Hexahedron1
MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1
END INTERFACE OrthogonalBasisGradient_Hexahedron
+!----------------------------------------------------------------------------
+! TensorProdBasisGradient_Hexahedron_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Evaluate all tensor product orthogoanl polynomial on hexahedron
+
+INTERFACE TensorProdBasisGradient_Hexahedron_
+ MODULE SUBROUTINE TensorProdBasisGradient_Hexahedron1_(p, q, r, &
+ xij, basisType1, basisType2, basisType3, &
+ ans, dim1, dim2, dim3, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, alpha3, beta3, lambda3)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! highest order in x1 direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! highest order in x2 direction
+ INTEGER(I4B), INTENT(IN) :: r
+ !! highest order in x3 direction
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ INTEGER(I4B), INTENT(IN) :: basisType1, basisType2, basisType3
+ !! basis type in x1 direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = (p + 1) * (q + 1) * (r + 1)
+ !! dim3 = 3
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! alpha1 needed when basisType1 "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! beta1 is needed when basisType1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! lambda1 is needed when basisType1 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! alpha2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! beta2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! lambda2 is needed when basisType2 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3
+ !! alpha3 needed when basisType3 "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta3
+ !! beta3 is needed when basisType3 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda3
+ !! lambda3 is needed when basisType3 is "Ultraspherical"
+ END SUBROUTINE TensorProdBasisGradient_Hexahedron1_
+END INTERFACE TensorProdBasisGradient_Hexahedron_
+
+INTERFACE OrthogonalBasisGradient_Hexahedron_
+ MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1_
+END INTERFACE OrthogonalBasisGradient_Hexahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Hexahedron
!----------------------------------------------------------------------------
@@ -2603,6 +3229,45 @@ MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron1( &
END FUNCTION HeirarchicalBasisGradient_Hexahedron1
END INTERFACE HeirarchicalBasisGradient_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Hexahedron_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Hexahedron1_(pb1, pb2, pb3, &
+ pxy1, pxy2, pxz1, pxz2, pyz1, pyz2, px1, px2, px3, px4, py1, py2, py3, &
+ py4, pz1, pz2, pz3, pz4, xij, ans, dim1, dim2, dim3)
+ INTEGER(I4B), INTENT(IN) :: pb1, pb2, pb3
+ !! order of interpolation inside the element in x, y, and z dirs
+ INTEGER(I4B), INTENT(IN) :: pxy1, pxy2
+ !! order of interpolation on facets parallel to xy plane
+ INTEGER(I4B), INTENT(IN) :: pxz1, pxz2
+ !! order of interpolation on facets parallel to xz plane
+ INTEGER(I4B), INTENT(IN) :: pyz1, pyz2
+ !! order of interpolation on facets parallel to yz plane
+ INTEGER(I4B), INTENT(IN) :: px1, px2, px3, px4
+ !! order of interpolation on edges parallel to x-axis
+ INTEGER(I4B), INTENT(IN) :: py1, py2, py3, py4
+ !! order of interpolation on edges parallel to y-axis
+ INTEGER(I4B), INTENT(IN) :: pz1, pz2, pz3, pz4
+ !! order of interpolation on edges parallel to z-axis
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) &
+ !! & + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B &
+ !! & + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B &
+ !! & + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B &
+ !! & + (px1 + px2 + px3 + px4 - 4_I4B) &
+ !! & + (py1 + py2 + py3 + py4 - 4_I4B) &
+ !! & + (pz1 + pz2 + pz3 + pz4 - 4_I4B)
+ !! dim3 = 3_I4B
+ END SUBROUTINE HeirarchicalBasisGradient_Hexahedron1_
+END INTERFACE HeirarchicalBasisGradient_Hexahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Hexahedron
!----------------------------------------------------------------------------
@@ -2633,4 +3298,30 @@ MODULE FUNCTION HeirarchicalBasisGradient_Hexahedron2( &
END FUNCTION HeirarchicalBasisGradient_Hexahedron2
END INTERFACE HeirarchicalBasisGradient_Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Hexahedron_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Hexahedron2_(p, q, r, xij, &
+ ans, dim1, dim2, dim3)
+ INTEGER(I4B), INTENT(IN) :: p, q, r
+ !! order of interpolation in x, y, and z dirs
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = 8_I4B + (p - 1_I4B) * (q - 1_I4B) * (r - 1_I4B) &
+ !! + (p - 1_I4B) * (q - 1_I4B) * 2_I4B &
+ !! + (p - 1_I4B) * (r - 1_I4B) * 2_I4B &
+ !! + (q - 1_I4B) * (r - 1_I4B) * 2_I4B &
+ !! + (4_I4B * p - 4_I4B) &
+ !! + (4_I4B * q - 4_I4B) &
+ !! + (4_I4B * r - 4_I4B)
+ !! dim3 = 3_I4B
+ END SUBROUTINE HeirarchicalBasisGradient_Hexahedron2_
+END INTERFACE HeirarchicalBasisGradient_Hexahedron_
+
END MODULE HexahedronInterpolationUtility
diff --git a/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90 b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90
new file mode 100644
index 000000000..bd2596980
--- /dev/null
+++ b/src/modules/Polynomial/src/HierarchicalPolynomialUtility.F90
@@ -0,0 +1,275 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.com
+! Vikas Sharma, Ph.D., vickysharma0812@gmail.com
+!
+! 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 HierarchicalPolynomialUtility
+USE GlobalData, ONLY: DFP, I4B, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: HierarchicalDOF
+PUBLIC :: HierarchicalVertexDOF
+PUBLIC :: HierarchicalEdgeDOF
+PUBLIC :: HierarchicalFaceDOF
+PUBLIC :: HierarchicalCellDOF
+
+PUBLIC :: HierarchicalEvalAll_
+PUBLIC :: HierarchicalEvalAll
+
+PUBLIC :: HierarchicalGradientEvalAll_
+PUBLIC :: HierarchicalGradientEvalAll
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-03
+! summary: Returns the total number of degree of freedom
+
+INTERFACE
+ MODULE PURE FUNCTION HierarchicalDOF(elemType, cellOrder, faceOrder, &
+ edgeOrder) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, alkways needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order needed for 1D elements
+ INTEGER(I4B) :: ans
+ !! number of degree of freedom
+ END FUNCTION HierarchicalDOF
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-03
+! summary: Returns the total number of degree of freedom
+
+INTERFACE
+ MODULE PURE FUNCTION HierarchicalVertexDOF(elemType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ INTEGER(I4B) :: ans
+ !! number of degree of freedom
+ END FUNCTION HierarchicalVertexDOF
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION HierarchicalEdgeDOF(order, elemType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order(:)
+ !! order,
+ !! the size of order should be same as
+ !! the total number of edges in element
+ INTEGER(I4B), INTENT(IN) :: elemType
+ INTEGER(I4B) :: ans
+ !! number of degree of freedom
+ END FUNCTION HierarchicalEdgeDOF
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION HierarchicalFaceDOF(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 HierarchicalFaceDOF
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! j
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION HierarchicalCellDOF(order, elemType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order(:)
+ !! order
+ !! for quadrangle element, size of order should be 2
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ INTEGER(I4B) :: ans
+ !! number of degree of freedom
+ END FUNCTION HierarchicalCellDOF
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE FUNCTION HierarchicalEvalAll(elemType, xij, domainName, &
+ cellOrder, faceOrder, edgeOrder, cellOrient, faceOrient, &
+ edgeOrient) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! Value of n+1 Hierarchical polynomials at point x
+ INTEGER(I4B), INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:, :)
+ !! face orientation
+ INTEGER(I4B), INTENT(IN) :: cellOrient(:)
+ !! cell orientation
+ END FUNCTION HierarchicalEvalAll
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE HierarchicalEvalAll_(elemType, xij, ans, nrow, &
+ ncol, domainName, cellOrder, faceOrder, edgeOrder, &
+ cellOrient, faceOrient, edgeOrient)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 Hierarchical polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x, 2)
+ !! ncol = SIZE(xij, 2)
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+ !! orientation of cell
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :)
+ !! orientation of face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ END SUBROUTINE HierarchicalEvalAll_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE FUNCTION HierarchicalGradientEvalAll(elemType, xij, &
+ domainName, cellOrder, faceOrder, edgeOrder, cellOrient, faceOrient, &
+ edgeOrient) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ REAL(DFP), ALLOCATABLE :: ans(:, :, :)
+ !! Value of n+1 Hierarchical polynomials at point x
+ INTEGER(I4B), INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:, :)
+ !! face orientation
+ INTEGER(I4B), INTENT(IN) :: cellOrient(:)
+ !! cell orientation
+ END FUNCTION HierarchicalGradientEvalAll
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE HierarchicalGradientEvalAll_(elemType, xij, ans, &
+ dim1, dim2, dim3, domainName, cellOrder, faceOrder, edgeOrder, &
+ cellOrient, faceOrient, edgeOrient)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! gradient of polynomials at quadrature points
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = SIZE(xij, 2)
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ !! cell order, always needed
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+ !! orientation of cell
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :)
+ !! orientation of face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ END SUBROUTINE HierarchicalGradientEvalAll_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE HierarchicalPolynomialUtility
diff --git a/src/modules/Polynomial/src/InterpolationUtility.F90 b/src/modules/Polynomial/src/InterpolationUtility.F90
index fc76c2f07..bfe3038ad 100644
--- a/src/modules/Polynomial/src/InterpolationUtility.F90
+++ b/src/modules/Polynomial/src/InterpolationUtility.F90
@@ -17,11 +17,16 @@
MODULE InterpolationUtility
USE GlobalData, ONLY: I4B, DFP, REAL32, REAL64
+USE String_Class, ONLY: String
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: VandermondeMatrix
PUBLIC :: GetTotalInDOF
PUBLIC :: GetTotalDOF
+PUBLIC :: RefElemDomain
!----------------------------------------------------------------------------
!
@@ -93,4 +98,27 @@ MODULE PURE FUNCTION GetTotalInDOF1(elemType, order, baseContinuity, &
END FUNCTION GetTotalInDOF1
END INTERFACE GetTotalInDOF
+!----------------------------------------------------------------------------
+! RefElemDomain
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-03
+! summary: Returns the coordinate of reference element
+
+INTERFACE
+ MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) &
+ RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! Element type
+ CHARACTER(*), INTENT(IN) :: baseContinuity
+ !! Cointinuity (conformity) of basis functions
+ !! "H1", "HDiv", "HCurl", "DG"
+ CHARACTER(*), INTENT(IN) :: baseInterpol
+ !! Basis function family for Interpolation
+ !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal
+ TYPE(String) :: ans
+ END FUNCTION RefElemDomain
+END INTERFACE
+
END MODULE InterpolationUtility
diff --git a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90 b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90
index c8357a7e4..23deb2412 100644
--- a/src/modules/Polynomial/src/JacobiPolynomialUtility.F90
+++ b/src/modules/Polynomial/src/JacobiPolynomialUtility.F90
@@ -22,10 +22,14 @@
!{!pages/JacobiPolynomialUtility.md!}
MODULE JacobiPolynomialUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
USE BaseType, ONLY: iface_1DFunction
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: GetJacobiRecurrenceCoeff
PUBLIC :: GetJacobiRecurrenceCoeff2
PUBLIC :: JacobiAlpha
@@ -44,12 +48,15 @@ MODULE JacobiPolynomialUtility
PUBLIC :: JacobiZeros
PUBLIC :: JacobiQuadrature
PUBLIC :: JacobiEvalAll
+PUBLIC :: JacobiEvalAll_
PUBLIC :: JacobiEval
PUBLIC :: JacobiEvalSum
PUBLIC :: JacobiGradientEval
PUBLIC :: JacobiGradientEvalAll
+PUBLIC :: JacobiGradientEvalAll_
PUBLIC :: JacobiGradientEvalSum
PUBLIC :: JacobiTransform
+PUBLIC :: JacobiTransform_
PUBLIC :: JacobiInvTransform
PUBLIC :: JacobiGradientCoeff
PUBLIC :: JacobiDMatrix
@@ -68,7 +75,7 @@ MODULE JacobiPolynomialUtility
INTERFACE
MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff(n, alpha, beta, &
- & alphaCoeff, betaCoeff)
+ alphaCoeff, betaCoeff)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial, it should be greater than 1
REAL(DFP), INTENT(IN) :: alpha
@@ -97,7 +104,7 @@ END SUBROUTINE GetJacobiRecurrenceCoeff
INTERFACE
MODULE PURE SUBROUTINE GetJacobiRecurrenceCoeff2(n, alpha, beta, &
- & A, B, C)
+ A, B, C)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial, it should be greater than 1
REAL(DFP), INTENT(IN) :: alpha
@@ -267,7 +274,7 @@ END FUNCTION JacobiNormSQRRatio
INTERFACE
MODULE PURE SUBROUTINE JacobiJacobiMatrix(n, alpha, beta, D, E, &
- & alphaCoeff, betaCoeff)
+ alphaCoeff, betaCoeff)
INTEGER(I4B), INTENT(IN) :: n
!! n should be greater than or equal to 1
REAL(DFP), INTENT(IN) :: alpha
@@ -318,7 +325,7 @@ END SUBROUTINE JacobiGaussQuadrature
INTERFACE
MODULE PURE SUBROUTINE JacobiJacobiRadauMatrix(a, n, alpha, beta, D, &
- & E, alphaCoeff, betaCoeff)
+ E, alphaCoeff, betaCoeff)
REAL(DFP), INTENT(IN) :: a
!! one of the end of the domain
INTEGER(I4B), INTENT(IN) :: n
@@ -385,7 +392,7 @@ END SUBROUTINE JacobiGaussRadauQuadrature
INTERFACE
MODULE PURE SUBROUTINE JacobiJacobiLobattoMatrix(n, alpha, beta, D, &
- & E, alphaCoeff, betaCoeff)
+ E, alphaCoeff, betaCoeff)
INTEGER(I4B), INTENT(IN) :: n
!! n should be greater than or equal to 1
REAL(DFP), INTENT(IN) :: alpha
@@ -534,6 +541,24 @@ MODULE PURE FUNCTION JacobiEvalAll1(n, alpha, beta, x) RESULT(ans)
END FUNCTION JacobiEvalAll1
END INTERFACE JacobiEvalAll
+!----------------------------------------------------------------------------
+! JacobiEvalAll
+!----------------------------------------------------------------------------
+
+INTERFACE JacobiEvalAll_
+ MODULE PURE SUBROUTINE JacobiEvalAll1_(n, alpha, beta, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: alpha
+ REAL(DFP), INTENT(IN) :: beta
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(n + 1)
+ !! Evaluate Jacobi polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE JacobiEvalAll1_
+END INTERFACE JacobiEvalAll_
+
!----------------------------------------------------------------------------
! JacobiEvalUpto
!----------------------------------------------------------------------------
@@ -565,6 +590,24 @@ MODULE PURE FUNCTION JacobiEvalAll2(n, alpha, beta, x) RESULT(ans)
END FUNCTION JacobiEvalAll2
END INTERFACE JacobiEvalAll
+!----------------------------------------------------------------------------
+! JacobiEvalAll
+!----------------------------------------------------------------------------
+
+INTERFACE JacobiEvalAll_
+ MODULE PURE SUBROUTINE JacobiEvalAll2_(n, alpha, beta, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: alpha
+ REAL(DFP), INTENT(IN) :: beta
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), n + 1)
+ !! Evaluate Jacobi polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE JacobiEvalAll2_
+END INTERFACE JacobiEvalAll_
+
!----------------------------------------------------------------------------
! JacobiEval
!----------------------------------------------------------------------------
@@ -734,6 +777,28 @@ MODULE PURE FUNCTION JacobiGradientEvalAll1(n, alpha, beta, x) RESULT(ans)
END FUNCTION JacobiGradientEvalAll1
END INTERFACE JacobiGradientEvalAll
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE JacobiGradientEvalAll_
+ MODULE PURE SUBROUTINE JacobiGradientEvalAll1_(n, alpha, beta, x, &
+ ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(n + 1)
+ !! Derivative of Jacobi polynomial of order n at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE JacobiGradientEvalAll1_
+END INTERFACE JacobiGradientEvalAll_
+
!----------------------------------------------------------------------------
! JacobiGradientEvalAll
!----------------------------------------------------------------------------
@@ -753,6 +818,24 @@ MODULE PURE FUNCTION JacobiGradientEvalAll2(n, alpha, beta, x) RESULT(ans)
END FUNCTION JacobiGradientEvalAll2
END INTERFACE JacobiGradientEvalAll
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE JacobiGradientEvalAll_
+ MODULE PURE SUBROUTINE JacobiGradientEvalAll2_(n, alpha, beta, x, &
+ ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: alpha
+ REAL(DFP), INTENT(IN) :: beta
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), n + 1)
+ !! Derivative of Jacobi polynomial of order n at x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE JacobiGradientEvalAll2_
+END INTERFACE JacobiGradientEvalAll_
+
!----------------------------------------------------------------------------
! JacobiGradientEvalSum
!----------------------------------------------------------------------------
@@ -791,7 +874,7 @@ END FUNCTION JacobiGradientEvalSum1
INTERFACE JacobiGradientEvalSum
MODULE PURE FUNCTION JacobiGradientEvalSum2(n, alpha, beta, x, coeff) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
REAL(DFP), INTENT(IN) :: alpha
@@ -818,7 +901,7 @@ END FUNCTION JacobiGradientEvalSum2
INTERFACE JacobiGradientEvalSum
MODULE PURE FUNCTION JacobiGradientEvalSum3(n, alpha, beta, x, coeff, k) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
REAL(DFP), INTENT(IN) :: alpha
@@ -847,7 +930,7 @@ END FUNCTION JacobiGradientEvalSum3
INTERFACE JacobiGradientEvalSum
MODULE PURE FUNCTION JacobiGradientEvalSum4(n, alpha, beta, x, coeff, k) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
REAL(DFP), INTENT(IN) :: alpha
@@ -875,7 +958,7 @@ END FUNCTION JacobiGradientEvalSum4
INTERFACE JacobiTransform
MODULE PURE FUNCTION JacobiTransform1(n, alpha, beta, coeff, x, w, &
- & quadType) RESULT(ans)
+ quadType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial
REAL(DFP), INTENT(IN) :: alpha
@@ -897,35 +980,69 @@ END FUNCTION JacobiTransform1
END INTERFACE JacobiTransform
!----------------------------------------------------------------------------
-! JacobiTransform
+! JacobiTransform_
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 13 Oct 2022
-! summary: Columnwise Discrete Jacobi Transform
+INTERFACE JacobiTransform_
+ MODULE PURE SUBROUTINE JacobiTransform1_(n, alpha, beta, coeff, x, w, &
+ quadType, ans, tsize)
+ 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:)
+ !! nodal value (at quad points)
+ !! size is number of quadrature points
+ REAL(DFP), INTENT(IN) :: x(0:)
+ !! quadrature points
+ !! size is quadrature points
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! weights
+ !! size is quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
+ !! GaussRadauRight
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! n+1
+ END SUBROUTINE JacobiTransform1_
+END INTERFACE JacobiTransform_
-INTERFACE JacobiTransform
- MODULE PURE FUNCTION JacobiTransform2(n, alpha, beta, coeff, x, w, &
- & quadType) RESULT(ans)
+!----------------------------------------------------------------------------
+! JacobiTransform
+!----------------------------------------------------------------------------
+
+INTERFACE JacobiTransform_
+ MODULE PURE SUBROUTINE JacobiTransform4_(n, alpha, beta, coeff, PP, w, &
+ quadType, ans, tsize)
INTEGER(I4B), INTENT(IN) :: n
- !! order of polynomial
+ !! 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:, 1:)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
!! nodal value (at quad points)
- REAL(DFP), INTENT(IN) :: x(0:n)
+ !! size is number of quadrature points
+ REAL(DFP), INTENT(IN) :: PP(0:, 0:)
!! quadrature points
- REAL(DFP), INTENT(IN) :: w(0:n)
+ !! number of rows in number of quadrature points
+ !! number of columns is n+1
+ REAL(DFP), INTENT(IN) :: w(0:)
!! weights
+ !! size is quadrature points
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 JacobiTransform
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! n+1
+ END SUBROUTINE JacobiTransform4_
+END INTERFACE JacobiTransform_
!----------------------------------------------------------------------------
! JacobiTransform
@@ -934,7 +1051,7 @@ END FUNCTION JacobiTransform2
!> 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
@@ -956,8 +1073,8 @@ END FUNCTION JacobiTransform2
!@endnote
INTERFACE JacobiTransform
- MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) &
- & RESULT(ans)
+ MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType, x1, x2) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial
REAL(DFP), INTENT(IN) :: alpha
@@ -969,11 +1086,45 @@ MODULE FUNCTION JacobiTransform3(n, alpha, beta, f, quadType) &
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
!! GaussRadauRight
+ REAL(DFP), INTENT(IN) :: x1, x2
+ !! domain of function f
REAL(DFP) :: ans(0:n)
!! modal values or coefficients
END FUNCTION JacobiTransform3
END INTERFACE JacobiTransform
+!----------------------------------------------------------------------------
+! JacobiTransform_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-19
+! summary: Jacobi transform
+
+INTERFACE JacobiTransform_
+ MODULE SUBROUTINE JacobiTransform3_(n, alpha, beta, f, quadType, x1, x2, &
+ ans, tsize)
+ 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), INTENT(IN) :: x1, x2
+ !! domain of function f
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! ans(0:n)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! n+1
+ END SUBROUTINE JacobiTransform3_
+END INTERFACE JacobiTransform_
+
!----------------------------------------------------------------------------
! JacobiInvTransform
!----------------------------------------------------------------------------
@@ -984,7 +1135,7 @@ END FUNCTION JacobiTransform3
INTERFACE JacobiInvTransform
MODULE PURE FUNCTION JacobiInvTransform1(n, alpha, beta, coeff, x) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: alpha
@@ -1010,7 +1161,7 @@ END FUNCTION JacobiInvTransform1
INTERFACE JacobiInvTransform
MODULE PURE FUNCTION JacobiInvTransform2(n, alpha, beta, coeff, x) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: alpha
diff --git a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90 b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90
index a5c151d8c..dde8431a2 100644
--- a/src/modules/Polynomial/src/LagrangePolynomialUtility.F90
+++ b/src/modules/Polynomial/src/LagrangePolynomialUtility.F90
@@ -29,75 +29,62 @@ MODULE LagrangePolynomialUtility
PUBLIC :: LagrangeDOF
PUBLIC :: LagrangeInDOF
PUBLIC :: LagrangeDegree
+
+PUBLIC :: EquidistancePoint
+PUBLIC :: EquidistancePoint_
+
PUBLIC :: LagrangeVandermonde
PUBLIC :: LagrangeVandermonde_
-PUBLIC :: EquidistancePoint
+
PUBLIC :: InterpolationPoint
-PUBLIC :: LagrangeCoeff
-PUBLIC :: RefCoord
-PUBLIC :: RefElemDomain
-PUBLIC :: LagrangeEvalAll
-PUBLIC :: LagrangeGradientEvalAll
+PUBLIC :: InterpolationPoint_
-!----------------------------------------------------------------------------
-! RefElemDomain
-!----------------------------------------------------------------------------
+PUBLIC :: LagrangeCoeff
+PUBLIC :: LagrangeCoeff_
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-03
-! summary: Returns the coordinate of reference element
+PUBLIC :: LagrangeEvalAll
+PUBLIC :: LagrangeEvalAll_
-INTERFACE
- MODULE FUNCTION RefElemDomain(elemType, baseContinuity, baseInterpol) &
- & RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: elemType
- !! Element type
- CHARACTER(*), INTENT(IN) :: baseContinuity
- !! Cointinuity (conformity) of basis functions
- !! "H1", "HDiv", "HCurl", "DG"
- CHARACTER(*), INTENT(IN) :: baseInterpol
- !! Basis function family for Interpolation
- !! Lagrange, Hierarchy, Serendipity, Hermit, Orthogonal
- TYPE(String) :: ans
- END FUNCTION RefElemDomain
-END INTERFACE
+PUBLIC :: LagrangeGradientEvalAll
+PUBLIC :: LagrangeGradientEvalAll_
!----------------------------------------------------------------------------
-! RefCoord
+! LagrangeDOF@BasisMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-03
-! summary: Returns the coordinate of reference element
+! date: 12 Aug 2022
+! summary: Returns the number of dof for lagrange polynomial
-INTERFACE
- MODULE PURE FUNCTION RefCoord(elemType, refElem) RESULT(ans)
+INTERFACE LagrangeDOF
+ MODULE PURE FUNCTION LagrangeDOF1(order, elemType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
INTEGER(I4B), INTENT(IN) :: elemType
- !! Element type
- CHARACTER(*), INTENT(IN) :: refElem
- !! "UNIT"
- !! "BIUNIT"
- REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION RefCoord
-END INTERFACE
+ INTEGER(I4B) :: ans
+ !! number of degree of freedom
+ END FUNCTION LagrangeDOF1
+END INTERFACE LagrangeDOF
!----------------------------------------------------------------------------
-! LagrangeDOF@BasisMethods
+!
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 12 Aug 2022
-! summary: Returns the number of dof for lagrange polynomial
+! date: 2024-07-11
+! summary: Get lagrange degree of freedom
-INTERFACE
- MODULE PURE FUNCTION LagrangeDOF(order, elemType) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order
+INTERFACE LagrangeDOF
+ MODULE PURE FUNCTION LagrangeDOF2(p, q, r, elemType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: p, q, r
+ !! order in x, y, and z direction
INTEGER(I4B), INTENT(IN) :: elemType
+ !! for line, triangle, tetrahedron, prism , and pyramid only p is used
+ !! for quadrangle and hexahedron, pq are used and pqr are used
INTEGER(I4B) :: ans
!! number of degree of freedom
- END FUNCTION LagrangeDOF
-END INTERFACE
+ END FUNCTION LagrangeDOF2
+END INTERFACE LagrangeDOF
!----------------------------------------------------------------------------
! LagrangeInDOF@BasisMethods
@@ -144,7 +131,7 @@ END FUNCTION LagrangeDegree
INTERFACE
MODULE PURE FUNCTION LagrangeVandermonde(xij, order, elemType) &
- & RESULT(ans)
+ RESULT(ans)
REAL(DFP), INTENT(IN) :: xij(:, :)
!! points in $x_{iJ}$ format
INTEGER(I4B), INTENT(IN) :: order
@@ -192,11 +179,7 @@ END SUBROUTINE LagrangeVandermonde_
! summary: Equidistance points on 1D/2D/3D elements
INTERFACE
- MODULE FUNCTION EquidistancePoint( &
- & order, &
- & elemType, &
- & xij) &
- & RESULT(ans)
+ MODULE FUNCTION EquidistancePoint(order, elemType, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of element
INTEGER(I4B), INTENT(IN) :: elemType
@@ -206,10 +189,7 @@ MODULE FUNCTION EquidistancePoint( &
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! nodal coordinates of linear elements
!! Default values:
- !! Biunit line
- !! Unit triangle
- !! Biunit Quadrangle
- !! Unit Tetrahedron
+ !! Biunit line ! Unit triangle ! Biunit Quadrangle ! Unit Tetrahedron
!! Biunit Hexahedron
REAL(DFP), ALLOCATABLE :: ans(:, :)
!! Equidistance points in xij format
@@ -219,6 +199,33 @@ MODULE FUNCTION EquidistancePoint( &
END FUNCTION EquidistancePoint
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE EquidistancePoint_(order, elemType, ans, nrow, ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of element
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! Element type
+ !! Point, Line, Triangle, Quadrangle, Tetrahedron
+ !! Hexahedron, Prism, Pyramid
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Equidistance points in xij format
+ !! Number of rows = nsd
+ !! Number of columns = Number of points
+ !! The number of points depend upon the order and elemType
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of linear elements
+ !! Default values:
+ !! Biunit line ! Unit triangle ! Biunit Quadrangle ! Unit Tetrahedron
+ !! Biunit Hexahedron
+ END SUBROUTINE EquidistancePoint_
+END INTERFACE
+
!----------------------------------------------------------------------------
! InterpolationPoint
!----------------------------------------------------------------------------
@@ -228,15 +235,8 @@ END FUNCTION EquidistancePoint
! summary: Get the interpolation point
INTERFACE
- MODULE FUNCTION InterpolationPoint( &
- & order, &
- & elemType, &
- & ipType, &
- & xij, &
- & layout, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION InterpolationPoint(order, elemType, ipType, xij, layout, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of interpolation
INTEGER(I4B), INTENT(IN) :: elemType
@@ -269,6 +269,51 @@ MODULE FUNCTION InterpolationPoint( &
END FUNCTION InterpolationPoint
END INTERFACE
+!----------------------------------------------------------------------------
+! InterpolationPoint
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Aug 2022
+! summary: Get the interpolation point
+
+INTERFACE
+ MODULE SUBROUTINE InterpolationPoint_(order, elemType, ipType, xij, layout, &
+ alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of interpolation
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type, following values are allowed.
+ !! Point, Line, Triangle, Quadrangle, Tetrahedron
+ !! Hexahedron, Prism, Pyramid
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation point type
+ !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev,
+ !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto,
+ !! GaussUltraspherical, GaussUltrasphericalLobatto
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! the number of rows and cols written in ans
+ CHARACTER(*), 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), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! Nodal coordinates of linear elements.
+ !! Domain of interpolation, default values are given by:
+ !! Biunit line
+ !! Unit triangle
+ !! Biunit Quadrangle
+ !! Unit Tetrahedron
+ !! Biunit Hexahedron
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ !! Jacobi and Ultraspherical parameters
+ END SUBROUTINE InterpolationPoint_
+END INTERFACE
+
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
@@ -292,6 +337,31 @@ MODULE FUNCTION LagrangeCoeff1(order, elemType, i, xij) RESULT(ans)
END FUNCTION LagrangeCoeff1
END INTERFACE LagrangeCoeff
+!----------------------------------------------------------------------------
+! LagrangeCoeff_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Oct 2022
+! summary: Returns the coefficient of ith lagrange poly
+
+INTERFACE LagrangeCoeff_
+ MODULE SUBROUTINE LagrangeCoeff1_(order, elemType, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff1_
+END INTERFACE LagrangeCoeff_
+
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
@@ -313,13 +383,36 @@ MODULE FUNCTION LagrangeCoeff2(order, elemType, xij) RESULT(ans)
END FUNCTION LagrangeCoeff2
END INTERFACE LagrangeCoeff
+!----------------------------------------------------------------------------
+! LagrangeCoeff
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Oct 2022
+! summary: Returns the coefficient of all lagrange poly
+
+INTERFACE LagrangeCoeff_
+ MODULE SUBROUTINE LagrangeCoeff2_(order, elemType, xij, ans, nrow, ncol)
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff2_
+END INTERFACE LagrangeCoeff_
+
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff
MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, &
- & isVandermonde) RESULT(ans)
+ isVandermonde) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial, it should be SIZE(v,2)-1
INTEGER(I4B), INTENT(IN) :: elemType
@@ -335,13 +428,36 @@ MODULE FUNCTION LagrangeCoeff3(order, elemType, i, v, &
END FUNCTION LagrangeCoeff3
END INTERFACE LagrangeCoeff
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_
+ MODULE SUBROUTINE LagrangeCoeff3_(order, elemType, i, v, &
+ isVandermonde, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff3_
+END INTERFACE LagrangeCoeff_
+
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff
- MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) &
- & RESULT(ans)
+ 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
@@ -357,21 +473,36 @@ MODULE FUNCTION LagrangeCoeff4(order, elemType, i, v, ipiv) &
END FUNCTION LagrangeCoeff4
END INTERFACE LagrangeCoeff
+!----------------------------------------------------------------------------
+! LagrangeCoeff
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_
+ MODULE SUBROUTINE LagrangeCoeff4_(order, elemType, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff4_
+END INTERFACE LagrangeCoeff_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll
!----------------------------------------------------------------------------
INTERFACE LagrangeEvalAll
- MODULE FUNCTION LagrangeEvalAll1( &
- & order, &
- & elemType, &
- & x, &
- & xij, &
- & domainName, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll1(order, elemType, x, xij, domainName, &
+ coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of Lagrange polynomials
INTEGER(I4B), INTENT(IN) :: elemType
@@ -403,21 +534,54 @@ MODULE FUNCTION LagrangeEvalAll1( &
END FUNCTION LagrangeEvalAll1
END INTERFACE LagrangeEvalAll
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_
+ MODULE SUBROUTINE LagrangeEvalAll1_(order, elemType, x, xij, ans, &
+ nrow, ncol, domainName, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x, 2)
+ !! ncol = SIZE(xij, 2)
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Jacobi=Dubiner
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE LagrangeEvalAll1_
+END INTERFACE LagrangeEvalAll_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll
!----------------------------------------------------------------------------
INTERFACE LagrangeGradientEvalAll
- MODULE FUNCTION LagrangeGradientEvalAll1( &
- & order, &
- & elemType, &
- & x, &
- & xij, &
- & domainName, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeGradientEvalAll1(order, elemType, x, xij, &
+ domainName, coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of Lagrange polynomials
INTEGER(I4B), INTENT(IN) :: elemType
@@ -453,4 +617,51 @@ END FUNCTION LagrangeGradientEvalAll1
!
!----------------------------------------------------------------------------
+INTERFACE LagrangeGradientEvalAll_
+ MODULE SUBROUTINE LagrangeGradientEvalAll1_(order, elemType, x, xij, ans, &
+ dim1, dim2, dim3, domainName, coeff, firstCall, basisType, alpha, &
+ beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of n+1 Lagrange polynomials at point x
+ !! dim1 = SIZE(x, 2)
+ !! dim2 = SIZE(xij, 2)
+ !! dim3 = SIZE(x, 1)
+ !! ans(:, :, 1) denotes x gradient
+ !! ans(:,:, 2) denotes y gradient
+ !! ans(:,:, 3) denotes z gradient
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! data written in ans
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Jacobi=Dubiner
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE LagrangeGradientEvalAll1_
+END INTERFACE LagrangeGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE LagrangePolynomialUtility
diff --git a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90 b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90
index 9c7ff28b6..6312061c9 100644
--- a/src/modules/Polynomial/src/LegendrePolynomialUtility.F90
+++ b/src/modules/Polynomial/src/LegendrePolynomialUtility.F90
@@ -22,10 +22,14 @@
!{!pages/LegendrePolynomialUtility.md!}
MODULE LegendrePolynomialUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
USE BaseType, ONLY: iface_1DFunction
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: LegendreAlpha
PUBLIC :: LegendreBeta
PUBLIC :: GetLegendreRecurrenceCoeff
@@ -45,13 +49,16 @@ MODULE LegendrePolynomialUtility
PUBLIC :: LegendreQuadrature
PUBLIC :: LegendreEval
PUBLIC :: LegendreEvalAll
+PUBLIC :: LegendreEvalAll_
PUBLIC :: LegendreMonomialExpansionAll
PUBLIC :: LegendreMonomialExpansion
PUBLIC :: LegendreGradientEvalAll
+PUBLIC :: LegendreGradientEvalAll_
PUBLIC :: LegendreGradientEval
PUBLIC :: LegendreEvalSum
PUBLIC :: LegendreGradientEvalSum
PUBLIC :: LegendreTransform
+PUBLIC :: LegendreTransform_
PUBLIC :: LegendreInvTransform
PUBLIC :: LegendreGradientCoeff
PUBLIC :: LegendreDMatrix
@@ -546,7 +553,7 @@ END FUNCTION LegendreEval2
!
!- x: the point at which the polynomials are to be evaluated.
-INTERFACE
+INTERFACE LegendreEvalAll
MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! Highest order of polynomial.
@@ -557,12 +564,27 @@ MODULE PURE FUNCTION LegendreEvalAll1(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! LegendreEvalAll_
+!----------------------------------------------------------------------------
+
+INTERFACE LegendreEvalAll_
+ MODULE PURE SUBROUTINE LegendreEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! Highest order of polynomial.
+ !! Polynomials from 0 to n will be computed.
+ REAL(DFP), INTENT(IN) :: x
+ !! Point of evaluation, $x \in [-1, 1]$
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(n + 1)
+ !! Evaluate Legendre polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LegendreEvalAll1_
+END INTERFACE LegendreEvalAll_
+
!----------------------------------------------------------------------------
! LegendreEvalAll
!----------------------------------------------------------------------------
@@ -587,7 +609,7 @@ END FUNCTION LegendreEvalAll1
! 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
+INTERFACE LegendreEvalAll
MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! Highest order of polynomial.
@@ -597,12 +619,32 @@ MODULE PURE FUNCTION LegendreEvalAll2(n, x) RESULT(ans)
REAL(DFP) :: ans(SIZE(x), n + 1)
!! shape (M,N+1)
END FUNCTION LegendreEvalAll2
-END INTERFACE
-
-INTERFACE LegendreEvalAll
- MODULE PROCEDURE LegendreEvalAll2
END INTERFACE LegendreEvalAll
+!----------------------------------------------------------------------------
+! LegendreEvalAll_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-19
+! summary: Evaluate Legendre polynomials from 0 to n at several points
+
+INTERFACE LegendreEvalAll_
+ MODULE PURE SUBROUTINE LegendreEvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! Highest order of polynomial.
+ !! Polynomials from 0 to n will be computed.
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! number of points, SIZE(x)=M
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), n + 1)
+ !! shape (M,N+1)
+ !! ans(:, jj) denotes value of Pjj at x
+ !! ans(ii, :) denotes value of all polynomials at x(ii)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LegendreEvalAll2_
+END INTERFACE LegendreEvalAll_
+
!----------------------------------------------------------------------------
! LegendreMonomialExpansionAll
!----------------------------------------------------------------------------
@@ -679,6 +721,25 @@ END FUNCTION LegendreGradientEvalAll1
!
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 8 Sept 2022
+! summary: Evaluate gradient of legendre polynomial of order upto n
+
+INTERFACE LegendreGradientEvalAll_
+ MODULE PURE SUBROUTINE LegendreGradientEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(1:n + 1)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size
+ END SUBROUTINE LegendreGradientEvalAll1_
+END INTERFACE LegendreGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of legendre polynomial of order upto n
@@ -695,6 +756,22 @@ END FUNCTION LegendreGradientEvalAll2
!
!----------------------------------------------------------------------------
+INTERFACE LegendreGradientEvalAll_
+ MODULE PURE SUBROUTINE LegendreGradientEvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(1:SIZE(x), 1:n + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x)
+ !! ncol = n + 1
+ END SUBROUTINE LegendreGradientEvalAll2_
+END INTERFACE LegendreGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of legendre polynomial of order upto n
@@ -703,17 +780,12 @@ END FUNCTION LegendreGradientEvalAll2
!
! Evaluate gradient of legendre polynomial of order upto n.
-INTERFACE
+INTERFACE LegendreGradientEval
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
!----------------------------------------------------------------------------
@@ -728,17 +800,12 @@ END FUNCTION LegendreGradientEval1
!
! Evaluate gradient of legendre polynomial of order upto n.
-INTERFACE
+INTERFACE LegendreGradientEval
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
!----------------------------------------------------------------------------
@@ -749,7 +816,7 @@ END FUNCTION LegendreGradientEval2
! date: 6 Sept 2022
! summary: Evaluate finite sum of Legendre polynomials at point x
-INTERFACE
+INTERFACE LegendreEvalSum
MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -761,10 +828,6 @@ MODULE PURE FUNCTION LegendreEvalSum1(n, x, coeff) &
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
!----------------------------------------------------------------------------
@@ -775,7 +838,7 @@ END FUNCTION LegendreEvalSum1
! date: 6 Sept 2022
! summary: Evaluate finite sum of Legendre polynomials at several x
-INTERFACE
+INTERFACE LegendreEvalSum
MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -786,10 +849,6 @@ MODULE PURE FUNCTION LegendreEvalSum2(n, x, coeff) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -801,7 +860,7 @@ END FUNCTION LegendreEvalSum2
! summary: Evaluate the gradient of finite sum of Legendre polynomials
! at point x
-INTERFACE
+INTERFACE LegendreGradientEvalSum
MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -812,10 +871,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum1(n, x, coeff) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -827,9 +882,8 @@ END FUNCTION LegendreGradientEvalSum1
! summary: Evaluate the gradient of finite sum of Legendre polynomials
! at several x
-INTERFACE
- MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) &
- & RESULT(ans)
+INTERFACE LegendreGradientEvalSum
+ MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
REAL(DFP), INTENT(IN) :: x(:)
@@ -839,10 +893,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum2(n, x, coeff) &
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
!----------------------------------------------------------------------------
@@ -854,7 +904,7 @@ END FUNCTION LegendreGradientEvalSum2
! summary: Evaluate the kth derivative of finite sum of Legendre
! polynomials at point x
-INTERFACE
+INTERFACE LegendreGradientEvalSum
MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -867,10 +917,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum3(n, x, coeff, k) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -882,7 +928,7 @@ END FUNCTION LegendreGradientEvalSum3
! summary: Evaluate the kth gradient of finite sum of Legendre
! polynomials at several x
-INTERFACE
+INTERFACE LegendreGradientEvalSum
MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -895,10 +941,6 @@ MODULE PURE FUNCTION LegendreGradientEvalSum4(n, x, coeff, k) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -909,62 +951,101 @@ END FUNCTION LegendreGradientEvalSum4
! date: 13 Oct 2022
! summary: Discrete Legendre Transform
-INTERFACE
+INTERFACE LegendreTransform
MODULE PURE FUNCTION LegendreTransform1(n, coeff, x, w, &
- & quadType) RESULT(ans)
+ quadType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Legendre polynomials
- REAL(DFP), INTENT(IN) :: coeff(0:n)
- !! nodal value (at quad points)
- REAL(DFP), INTENT(IN) :: x(0:n)
+ !! n+1 coefficient (modal values)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! value of function at quadrature points
+ !! size if number of quadrature points
+ !! number of quadrature points should be at least n+1
+ REAL(DFP), INTENT(IN) :: x(0:)
!! quadrature points
- REAL(DFP), INTENT(IN) :: w(0:n)
+ !! These quadrature points are used in LegendreEvalAll method
+ !! size is number of quadrature points
+ REAL(DFP), INTENT(IN) :: w(0:)
!! weights
+ !! size is number of quadrature points
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
!! GaussRadauRight
REAL(DFP) :: ans(0:n)
- !! modal values or coefficients
+ !! modal values or coefficients of Legendre polynomial
+ !! ans(0) is coefficient of P0
+ !! ans(1) is coefficient of P1
+ !! and so on
END FUNCTION LegendreTransform1
-END INTERFACE
-
-INTERFACE LegendreTransform
- MODULE PROCEDURE LegendreTransform1
END INTERFACE LegendreTransform
!----------------------------------------------------------------------------
-! LegendreTransform
+! LegendreTransform@Methods
!----------------------------------------------------------------------------
-!> 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)
+INTERFACE LegendreTransform_
+ MODULE PURE SUBROUTINE LegendreTransform1_(n, coeff, x, w, quadType, ans, &
+ tsize)
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
+ !! Order of Legendre polynomials
+ !! n+1 coefficient (modal values)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! Value of function at quadrature points
+ REAL(DFP), INTENT(IN) :: x(0:)
+ !! Quadrature points
+ !! These quadrature points are used in LegendreEvalAll method
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! 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
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients of Legendre polynomial
+ !! ans(0) is coefficient of P0
+ !! ans(1) is coefficient of P1
+ !! and so on
+ ! REAL(DFP) :: ans(0:n)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size of ans
+ END SUBROUTINE LegendreTransform1_
+END INTERFACE LegendreTransform_
-INTERFACE LegendreTransform
- MODULE PROCEDURE LegendreTransform2
-END INTERFACE LegendreTransform
+!----------------------------------------------------------------------------
+! LegendreTransform
+!----------------------------------------------------------------------------
+
+INTERFACE LegendreTransform_
+ MODULE PURE SUBROUTINE LegendreTransform4_(n, coeff, PP, w, quadType, ans, &
+ tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! Order of Legendre polynomials
+ !! n+1 coefficient (modal values)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! Value of function at quadrature points
+ !! size is number of quadrature points
+ REAL(DFP), INTENT(IN) :: PP(0:, 0:)
+ !! Quadrature points
+ !! These quadrature points are used in LegendreEvalAll method
+ !! number of rows in PP is number of quadrature points
+ !! number of columns in PP is n+1
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! Weights
+ !! soze of w is number of quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients of Legendre polynomial
+ !! ans(0) is coefficient of P0
+ !! ans(1) is coefficient of P1
+ !! and so on
+ ! REAL(DFP) :: ans(0:n)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size of ans
+ END SUBROUTINE LegendreTransform4_
+END INTERFACE LegendreTransform_
!----------------------------------------------------------------------------
-! LegendreTransform
+! LegendreTransform
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -991,9 +1072,8 @@ END FUNCTION LegendreTransform2
! `LegendreQuadrature` which is not pure due to Lapack call.
!@endnote
-INTERFACE
- MODULE FUNCTION LegendreTransform3(n, f, quadType) &
- & RESULT(ans)
+INTERFACE LegendreTransform
+ MODULE FUNCTION LegendreTransform3(n, f, quadType, x1, x2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial
PROCEDURE(iface_1DFunction), POINTER, INTENT(IN) :: f
@@ -1001,26 +1081,47 @@ MODULE FUNCTION LegendreTransform3(n, f, quadType) &
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
!! GaussRadauRight
+ REAL(DFP), INTENT(IN) :: x1, x2
+ !! domain of function f
REAL(DFP) :: ans(0:n)
!! modal values or coefficients
END FUNCTION LegendreTransform3
-END INTERFACE
-
-INTERFACE LegendreTransform
- MODULE PROCEDURE LegendreTransform3
END INTERFACE LegendreTransform
!----------------------------------------------------------------------------
-! LegendreInvTransform
+! LegendreTransform@Methods
+!----------------------------------------------------------------------------
+
+INTERFACE LegendreTransform_
+ MODULE SUBROUTINE LegendreTransform3_(n, f, quadType, x1, x2, ans, tsize)
+ 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), INTENT(IN) :: x1, x2
+ !! domain of function f
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients
+ !! ans(0:n)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! n+1
+ END SUBROUTINE LegendreTransform3_
+END INTERFACE LegendreTransform_
+
+!----------------------------------------------------------------------------
+! LegendreInvTransform
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 13 Oct 2022
! summary: Inverse Legendre Transform
-INTERFACE
+INTERFACE LegendreInvTransform
MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: coeff(0:n)
@@ -1030,23 +1131,19 @@ MODULE PURE FUNCTION LegendreInvTransform1(n, coeff, x) &
REAL(DFP) :: ans
!! value in physical space
END FUNCTION LegendreInvTransform1
-END INTERFACE
-
-INTERFACE LegendreInvTransform
- MODULE PROCEDURE LegendreInvTransform1
END INTERFACE LegendreInvTransform
!----------------------------------------------------------------------------
-! LegendreInvTransform
+! LegendreInvTransform
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 13 Oct 2022
! summary: Inverse Legendre Transform
-INTERFACE
+INTERFACE LegendreInvTransform
MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: coeff(0:n)
@@ -1056,14 +1153,10 @@ MODULE PURE FUNCTION LegendreInvTransform2(n, coeff, x) &
REAL(DFP) :: ans(SIZE(x))
!! value in physical space
END FUNCTION LegendreInvTransform2
-END INTERFACE
-
-INTERFACE LegendreInvTransform
- MODULE PROCEDURE LegendreInvTransform2
END INTERFACE LegendreInvTransform
!----------------------------------------------------------------------------
-! LegendreGradientCoeff
+! LegendreGradientCoeff
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1076,9 +1169,9 @@ END FUNCTION LegendreInvTransform2
!- Input is coefficient of Legendre expansion (modal values)
!- Output is coefficient of derivative of legendre expansion (modal values)
-INTERFACE
+INTERFACE LegendreGradientCoeff
MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: coeff(0:n)
@@ -1086,10 +1179,6 @@ MODULE PURE FUNCTION LegendreGradientCoeff1(n, coeff) &
REAL(DFP) :: ans(0:n)
!! coefficient of gradient
END FUNCTION LegendreGradientCoeff1
-END INTERFACE
-
-INTERFACE LegendreGradientCoeff
- MODULE PROCEDURE LegendreGradientCoeff1
END INTERFACE LegendreGradientCoeff
!----------------------------------------------------------------------------
@@ -1100,9 +1189,9 @@ END FUNCTION LegendreGradientCoeff1
! date: 15 Oct 2022
! summary: Returns differentiation matrix for Legendre expansion
-INTERFACE
+INTERFACE LegendreDMatrix
MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Legendre polynomial
REAL(DFP), INTENT(IN) :: x(0:n)
@@ -1112,21 +1201,17 @@ MODULE PURE FUNCTION LegendreDMatrix1(n, x, quadType) &
REAL(DFP) :: ans(0:n, 0:n)
!! D matrix
END FUNCTION LegendreDMatrix1
-END INTERFACE
-
-INTERFACE LegendreDMatrix
- MODULE PROCEDURE LegendreDMatrix1
END INTERFACE LegendreDMatrix
!----------------------------------------------------------------------------
-! LegendreDMatEvenOdd
+! LegendreDMatEvenOdd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 15 Oct 2022
! summary: Performs even and odd decomposition of Differential matrix
-INTERFACE
+INTERFACE LegendreDMatEvenOdd
MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o)
INTEGER(I4B), INTENT(IN) :: n
!! order of Legendre polynomial
@@ -1137,10 +1222,6 @@ MODULE PURE SUBROUTINE LegendreDMatEvenOdd1(n, D, e, o)
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
!----------------------------------------------------------------------------
diff --git a/src/modules/Polynomial/src/LineInterpolationUtility.F90 b/src/modules/Polynomial/src/LineInterpolationUtility.F90
index dda86c81d..f7fec78cd 100644
--- a/src/modules/Polynomial/src/LineInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/LineInterpolationUtility.F90
@@ -16,7 +16,7 @@
!
MODULE LineInterpolationUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
USE String_Class, ONLY: String
IMPLICIT NONE
PRIVATE
@@ -28,21 +28,41 @@ MODULE LineInterpolationUtility
PUBLIC :: GetTotalDOF_Line
PUBLIC :: GetTotalInDOF_Line
PUBLIC :: EquidistanceInPoint_Line
+PUBLIC :: EquidistanceInPoint_Line_
PUBLIC :: EquidistancePoint_Line
+PUBLIC :: EquidistancePoint_Line_
PUBLIC :: InterpolationPoint_Line
+PUBLIC :: InterpolationPoint_Line_
PUBLIC :: LagrangeCoeff_Line
+PUBLIC :: LagrangeCoeff_Line_
PUBLIC :: LagrangeEvalAll_Line
+PUBLIC :: LagrangeEvalAll_Line_
PUBLIC :: LagrangeGradientEvalAll_Line
+PUBLIC :: LagrangeGradientEvalAll_Line_
+
PUBLIC :: BasisEvalAll_Line
+PUBLIC :: BasisEvalAll_Line_
+
PUBLIC :: BasisGradientEvalAll_Line
+PUBLIC :: BasisGradientEvalAll_Line_
+
PUBLIC :: QuadraturePoint_Line
+PUBLIC :: QuadraturePoint_Line_
+
PUBLIC :: ToVEFC_Line
PUBLIC :: QuadratureNumber_Line
PUBLIC :: RefElemDomain_Line
+
PUBLIC :: HeirarchicalBasis_Line
-PUBLIC :: HeirarchicalGradientBasis_Line
+PUBLIC :: HeirarchicalBasis_Line_
+
+PUBLIC :: HeirarchicalBasisGradient_Line
+PUBLIC :: HeirarchicalBasisGradient_Line_
+
PUBLIC :: OrthogonalBasis_Line
+PUBLIC :: OrthogonalBasis_Line_
PUBLIC :: OrthogonalBasisGradient_Line
+PUBLIC :: OrthogonalBasisGradient_Line_
!----------------------------------------------------------------------------
! RefElemDomain_Line
@@ -178,7 +198,9 @@ MODULE PURE FUNCTION GetTotalDOF_Line(order, baseContinuity, &
baseInterpolation) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
CHARACTER(*), INTENT(IN) :: baseContinuity
+ !! not used
CHARACTER(*), INTENT(IN) :: baseInterpolation
+ !! not used
INTEGER(I4B) :: ans
END FUNCTION GetTotalDOF_Line
END INTERFACE
@@ -232,6 +254,21 @@ MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans)
END FUNCTION EquidistanceInPoint_Line1
END INTERFACE EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistanceInPoint_Line_
+ MODULE PURE SUBROUTINE EquidistanceInPoint_Line1_(order, xij, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(IN) :: xij(2)
+ !! coordinates of point 1 and point 2
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE EquidistanceInPoint_Line1_
+END INTERFACE EquidistanceInPoint_Line_
+
!----------------------------------------------------------------------------
! EquidistanceInPoint_Line
!----------------------------------------------------------------------------
@@ -252,18 +289,39 @@ END FUNCTION EquidistanceInPoint_Line1
INTERFACE EquidistanceInPoint_Line
MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
- !! order
+ !! order
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
- !! coordinates of point 1 and point 2 in $x_{iJ}$ format
- !! number of rows = nsd
- !! number of cols = 2
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 2
REAL(DFP), ALLOCATABLE :: ans(:, :)
- !! Equidistnace points in $x_{iJ}$ format
- !! The number of rows is equal to the number of rows in xij
- !! (if xij present), otherwise, it is 1.
+ !! Equidistnace points in $x_{iJ}$ format
+ !! The number of rows is equal to the number of rows in xij
+ !! (if xij present), otherwise, it is 1.
END FUNCTION EquidistanceInPoint_Line2
END INTERFACE EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistanceInPoint_Line_
+ MODULE PURE SUBROUTINE EquidistanceInPoint_Line2_(order, xij, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 2
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Equidistnace points in $x_{iJ}$ format
+ !! The number of rows is equal to the number of rows in xij
+ !! (if xij present), otherwise, it is 1.
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE EquidistanceInPoint_Line2_
+END INTERFACE EquidistanceInPoint_Line_
+
!----------------------------------------------------------------------------
! EquidistancePoint_Line
!----------------------------------------------------------------------------
@@ -289,6 +347,22 @@ MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) &
END FUNCTION EquidistancePoint_Line1
END INTERFACE EquidistancePoint_Line
+!----------------------------------------------------------------------------
+! EquidistancePoint_Line_
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistancePoint_Line_
+ MODULE PURE SUBROUTINE EquidistancePoint_Line1_(order, xij, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(IN) :: xij(2)
+ !! coorindates of point 1 and point 2
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! equidistance points
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE EquidistancePoint_Line1_
+END INTERFACE EquidistancePoint_Line_
+
!----------------------------------------------------------------------------
! EquidistancePoint_Line
!----------------------------------------------------------------------------
@@ -319,6 +393,27 @@ MODULE PURE FUNCTION EquidistancePoint_Line2(order, xij) &
END FUNCTION EquidistancePoint_Line2
END INTERFACE EquidistancePoint_Line
+!----------------------------------------------------------------------------
+! EquidistancePoint_Line_
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistancePoint_Line_
+ MODULE PURE SUBROUTINE EquidistancePoint_Line2_(order, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 2
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! equidistance points in $x_{iJ}$ format
+ !! If xij is not present, then number of rows in ans
+ !! is 1. If `xij` is present then the number of rows in
+ !! ans is same as xij.
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE EquidistancePoint_Line2_
+END INTERFACE EquidistancePoint_Line_
+
!----------------------------------------------------------------------------
! InterpolationPoint_Line
!----------------------------------------------------------------------------
@@ -355,7 +450,7 @@ END FUNCTION EquidistancePoint_Line2
INTERFACE InterpolationPoint_Line
MODULE FUNCTION InterpolationPoint_Line1(order, ipType, &
- & layout, xij, alpha, beta, lambda) RESULT(ans)
+ layout, xij, alpha, beta, lambda) RESULT(ans)
!!
INTEGER(I4B), INTENT(IN) :: order
!! Order of interpolation
@@ -381,6 +476,43 @@ MODULE FUNCTION InterpolationPoint_Line1(order, ipType, &
END FUNCTION InterpolationPoint_Line1
END INTERFACE InterpolationPoint_Line
+!----------------------------------------------------------------------------
+! InterpolationPoint_Line_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-25
+! summary: Interpolation without allocation
+
+INTERFACE InterpolationPoint_Line_
+ MODULE SUBROUTINE InterpolationPoint_Line1_(order, ipType, ans, nrow, ncol, &
+ layout, xij, alpha, beta, lambda)
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in xij format
+ !! size(ans,1) = 1
+ !! size(ans,2) = order+1
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written to ans
+ CHARACTER(*), INTENT(IN) :: layout
+ !! "VEFC"
+ !! "INCREASING"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! domain of interpolation
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE InterpolationPoint_Line1_
+END INTERFACE InterpolationPoint_Line_
+
!----------------------------------------------------------------------------
! InterpolationPoint_Line
!----------------------------------------------------------------------------
@@ -391,7 +523,7 @@ END FUNCTION InterpolationPoint_Line1
INTERFACE InterpolationPoint_Line
MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, &
- & layout, alpha, beta, lambda) RESULT(ans)
+ layout, alpha, beta, lambda) RESULT(ans)
!!
INTEGER(I4B), INTENT(IN) :: order
!! order of interpolation
@@ -421,6 +553,38 @@ MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, &
END FUNCTION InterpolationPoint_Line2
END INTERFACE InterpolationPoint_Line
+!----------------------------------------------------------------------------
+! InterpolationPoint_Line_
+!----------------------------------------------------------------------------
+
+INTERFACE InterpolationPoint_Line_
+ MODULE SUBROUTINE InterpolationPoint_Line2_(order, ipType, ans, tsize, &
+ xij, layout, alpha, beta, lambda)
+ !!
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of interpolation
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Interpolation point type
+ !! See TypeInterpolationOpt
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! one dimensional interpolation point
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size of ans
+ REAL(DFP), INTENT(IN) :: xij(2)
+ !! end points
+ CHARACTER(*), INTENT(IN) :: layout
+ !! "VEFC"
+ !! "INCREASING"
+ !! "DECREASING"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE InterpolationPoint_Line2_
+END INTERFACE InterpolationPoint_Line_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
@@ -442,6 +606,25 @@ END FUNCTION LagrangeCoeff_Line1
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
+INTERFACE LagrangeCoeff_Line_
+ MODULE SUBROUTINE LagrangeCoeff_Line1_(order, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(order + 1)
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Line1_
+END INTERFACE LagrangeCoeff_Line_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
INTERFACE LagrangeCoeff_Line
MODULE FUNCTION LagrangeCoeff_Line2(order, i, v, isVandermonde) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
@@ -461,6 +644,28 @@ END FUNCTION LagrangeCoeff_Line2
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
+INTERFACE LagrangeCoeff_Line_
+ MODULE SUBROUTINE LagrangeCoeff_Line2_(order, i, v, isVandermonde, ans, &
+ tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(order + 1)
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Line2_
+END INTERFACE LagrangeCoeff_Line_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
INTERFACE LagrangeCoeff_Line
MODULE FUNCTION LagrangeCoeff_Line3(order, i, v, ipiv) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
@@ -480,6 +685,27 @@ END FUNCTION LagrangeCoeff_Line3
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
+INTERFACE LagrangeCoeff_Line_
+ MODULE SUBROUTINE LagrangeCoeff_Line3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(order + 1)
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Line3_
+END INTERFACE LagrangeCoeff_Line_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
INTERFACE LagrangeCoeff_Line
MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
@@ -493,24 +719,38 @@ MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans)
END FUNCTION LagrangeCoeff_Line4
END INTERFACE LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Line_
+ MODULE SUBROUTINE LagrangeCoeff_Line4_(order, xij, ans, nrow, ncol)
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! ans(order + 1, order + 1)
+ !! coefficients
+ !! jth column of ans corresponds to the coeff of lagrange polynomial
+ !! at the jth point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Line4_
+END INTERFACE LagrangeCoeff_Line_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Line
MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, &
- & beta, lambda) RESULT(ans)
+ beta, lambda) 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
INTEGER(I4B), INTENT(IN) :: basisType
- !! Monomial
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Lobatto
- !! UnscaledLobatto
+ !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
@@ -524,6 +764,34 @@ MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, &
END FUNCTION LagrangeCoeff_Line5
END INTERFACE LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Line_
+ MODULE SUBROUTINE LagrangeCoeff_Line5_(order, xij, basisType, alpha, &
+ beta, lambda, ans, nrow, ncol)
+ 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
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ !! jth column of ans corresponds to the coeff of lagrange polynomial
+ !! at the jth point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Line5_
+END INTERFACE LagrangeCoeff_Line_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Line
!----------------------------------------------------------------------------
@@ -534,8 +802,7 @@ END FUNCTION LagrangeCoeff_Line5
INTERFACE LagrangeEvalAll_Line
MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, &
- & basisType, alpha, beta, lambda) &
- & RESULT(ans)
+ basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x
@@ -549,12 +816,7 @@ MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, &
!! If firstCall is False, then coeff will be used
!! Default value of firstCall is True
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Monomial
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Lobatto
- !! UnscaledLobatto
+ !! Monomial Jacobi Legendre Chebyshev Lobatto UnscaledLobatto
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
@@ -566,6 +828,41 @@ MODULE FUNCTION LagrangeEvalAll_Line1(order, x, xij, coeff, firstCall, &
END FUNCTION LagrangeEvalAll_Line1
END INTERFACE LagrangeEvalAll_Line
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line_
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Line_
+ MODULE SUBROUTINE LagrangeEvalAll_Line1_(order, x, xij, coeff, firstCall, &
+ basisType, alpha, beta, lambda, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial Jacobi Legendre Chebyshev Lobatto UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeEvalAll_Line1_
+END INTERFACE LagrangeEvalAll_Line_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Line
!----------------------------------------------------------------------------
@@ -575,10 +872,8 @@ END FUNCTION LagrangeEvalAll_Line1
! summary: Evaluate Lagrange polynomials of n at several points
INTERFACE LagrangeEvalAll_Line
- MODULE FUNCTION LagrangeEvalAll_Line2( &
- & order, x, xij, coeff, firstCall, &
- & basisType, alpha, beta, lambda) &
- & RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll_Line2(order, x, xij, coeff, firstCall, &
+ basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(:, :)
@@ -616,6 +911,49 @@ MODULE FUNCTION LagrangeEvalAll_Line2( &
END FUNCTION LagrangeEvalAll_Line2
END INTERFACE LagrangeEvalAll_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Line_
+ MODULE SUBROUTINE LagrangeEvalAll_Line2_(order, x, xij, ans, nrow, ncol, &
+ coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! point of evaluation in xij format
+ !! size(xij, 1) = nsd
+ !! size(xij, 2) = number of points
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ !! xij should be present when firstCall is true.
+ !! It is used for computing the coeff
+ !! If coeff is absent then xij should be present
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x, 2), SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ !! ans(:, j) is the value of jth polynomial at x points
+ !! ans(i, :) is the value of all polynomials at x(i) point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nubmer of rows and cols writte in ans
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial, Jacobi, Legendre, Chebyshev, Lobatto, UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Line2_
+END INTERFACE LagrangeEvalAll_Line_
+
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Line
!----------------------------------------------------------------------------
@@ -625,14 +963,8 @@ END FUNCTION LagrangeEvalAll_Line2
! summary: Evaluate Lagrange polynomials of n at several points
INTERFACE LagrangeGradientEvalAll_Line
- MODULE FUNCTION LagrangeGradientEvalAll_Line1( &
- & order, &
- & x, &
- & xij, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeGradientEvalAll_Line1(order, x, xij, coeff, &
+ firstCall, basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(:, :)
@@ -671,31 +1003,66 @@ END FUNCTION LagrangeGradientEvalAll_Line1
END INTERFACE LagrangeGradientEvalAll_Line
!----------------------------------------------------------------------------
-! BasisEvalAll_Line
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! summary: Evaluate basis functions of order upto n
-
-INTERFACE BasisEvalAll_Line
- MODULE FUNCTION BasisEvalAll_Line1( &
- & order, &
- & x, &
- & refLine, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+INTERFACE LagrangeGradientEvalAll_Line_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_(order, x, xij, ans, &
+ dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, lambda)
INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomials
- REAL(DFP), INTENT(IN) :: x
- !! point of evaluation
- CHARACTER(*), INTENT(IN) :: refLine
- !! Refline should be BIUNIT
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Monomial
- !! Jacobi
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! point of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ !! xij should be present when firstCall is true.
+ !! It is used for computing the coeff
+ !! If coeff is absent then xij should be present
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! ans(SIZE(x, 2), SIZE(xij, 2), 1)
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Line1_
+END INTERFACE LagrangeGradientEvalAll_Line_
+
+!----------------------------------------------------------------------------
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate basis functions of order upto n
+
+INTERFACE BasisEvalAll_Line
+ MODULE FUNCTION BasisEvalAll_Line1(order, x, refLine, basisType, alpha, &
+ beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: x
+ !! point of evaluation
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! Refline should be BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial
+ !! Jacobi
!! Ultraspherical
!! Legendre
!! Chebyshev
@@ -712,6 +1079,40 @@ MODULE FUNCTION BasisEvalAll_Line1( &
END FUNCTION BasisEvalAll_Line1
END INTERFACE BasisEvalAll_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE BasisEvalAll_Line_
+ MODULE SUBROUTINE BasisEvalAll_Line1_(order, x, ans, tsize, refLine, &
+ basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: x
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(order + 1)
+ !! Value of n+1 polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! Refline should be BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial
+ !! Jacobi
+ !! Ultraspherical
+ !! Legendre
+ !! Chebyshev
+ !! Lobatto
+ !! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE BasisEvalAll_Line1_
+END INTERFACE BasisEvalAll_Line_
+
!----------------------------------------------------------------------------
! BasisEvalAll_Line
!----------------------------------------------------------------------------
@@ -721,14 +1122,8 @@ END FUNCTION BasisEvalAll_Line1
! summary: Evaluate basis functions of order upto n
INTERFACE BasisEvalAll_Line
- MODULE FUNCTION BasisEvalAll_Line2( &
- & order, &
- & x, &
- & refLine, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION BasisEvalAll_Line2(order, x, refLine, basisType, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomials
REAL(DFP), INTENT(IN) :: x(:)
@@ -757,6 +1152,44 @@ MODULE FUNCTION BasisEvalAll_Line2( &
END FUNCTION BasisEvalAll_Line2
END INTERFACE BasisEvalAll_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE BasisEvalAll_Line_
+ MODULE SUBROUTINE BasisEvalAll_Line2_(order, x, ans, nrow, ncol, &
+ refLine, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), order + 1)
+ !! Value of n+1 polynomials at point x
+ !! ans(:, j) is the value of jth polynomial at x points
+ !! ans(i, :) is the value of all polynomials at x(i) point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written to ans
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! UNIT
+ !! BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial
+ !! Jacobi
+ !! Ultraspherical
+ !! Legendre
+ !! Chebyshev
+ !! Lobatto
+ !! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE BasisEvalAll_Line2_
+END INTERFACE BasisEvalAll_Line_
+
!----------------------------------------------------------------------------
! BasisEvalAll_Line
!----------------------------------------------------------------------------
@@ -766,28 +1199,17 @@ END FUNCTION BasisEvalAll_Line2
! summary: Evaluate basis functions of order upto n
INTERFACE OrthogonalBasis_Line
- MODULE FUNCTION OrthogonalBasis_Line1( &
- & order, &
- & xij, &
- & refLine, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION OrthogonalBasis_Line1(order, xij, refLine, basisType, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomials
REAL(DFP), INTENT(IN) :: xij(:, :)
!! point of evaluation
!! Number of rows in xij is 1
CHARACTER(*), INTENT(IN) :: refLine
- !! UNIT
- !! BIUNIT
+ !! UNIT ! BIUNIT
INTEGER(I4B), INTENT(IN) :: basisType
- !! Jacobi
- !! Ultraspherical
- !! Legendre
- !! Chebyshev
- !! Lobatto
+ !! Jacobi ! Ultraspherical ! Legendre ! Chebyshev ! Lobatto
!! UnscaledLobatto
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi polynomial parameter
@@ -802,6 +1224,40 @@ MODULE FUNCTION OrthogonalBasis_Line1( &
END FUNCTION OrthogonalBasis_Line1
END INTERFACE OrthogonalBasis_Line
+!----------------------------------------------------------------------------
+! OrthogonalBasis_Line_
+!----------------------------------------------------------------------------
+
+INTERFACE OrthogonalBasis_Line_
+ MODULE SUBROUTINE OrthogonalBasis_Line1_(order, xij, refLine, basisType, &
+ ans, nrow, ncol, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! point of evaluation
+ !! Number of rows in xij is 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! Jacobi ! Ultraspherical ! Legendre ! Chebyshev ! Lobatto
+ !! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 polynomials at point x
+ ! ans(SIZE(xij, 2), order + 1)
+ !! ans(:, j) is the value of jth polynomial at x points
+ !! ans(i, :) is the value of all polynomials at x(i) point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = size(xij, 2)
+ !! ncol = order+1
+ END SUBROUTINE OrthogonalBasis_Line1_
+END INTERFACE OrthogonalBasis_Line_
+
!----------------------------------------------------------------------------
! BasisEvalAll_Line
!----------------------------------------------------------------------------
@@ -811,14 +1267,8 @@ END FUNCTION OrthogonalBasis_Line1
! summary: Evaluate basis functions of order upto n
INTERFACE OrthogonalBasisGradient_Line
- MODULE FUNCTION OrthogonalBasisGradient_Line1( &
- & order, &
- & xij, &
- & refLine, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION OrthogonalBasisGradient_Line1(order, xij, refLine, &
+ basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomials
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -847,6 +1297,50 @@ MODULE FUNCTION OrthogonalBasisGradient_Line1( &
END FUNCTION OrthogonalBasisGradient_Line1
END INTERFACE OrthogonalBasisGradient_Line
+!----------------------------------------------------------------------------
+! OrthgonalBasisGradient_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-09-10
+! summary: gradient of orthogonal basis without allocation
+
+INTERFACE OrthogonalBasisGradient_Line_
+ MODULE SUBROUTINE OrthogonalBasisGradient_Line1_(order, xij, refLine, &
+ basisType, ans, dim1, dim2, dim3, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! point of evaluation
+ !! Number of rows in xij is 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! UNIT
+ !! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! Jacobi
+ !! Ultraspherical
+ !! Legendre
+ !! Chebyshev
+ !! Lobatto
+ !! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! ans(SIZE(xij, 2), order + 1, 1)
+ !! Value of n+1 polynomials at point x
+ !! ans(:, j) is the value of jth polynomial at x points
+ !! ans(i, :) is the value of all polynomials at x(i) point
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = size(xij,2)
+ !! dim2 = order+1
+ !! dim3 = 1
+ END SUBROUTINE OrthogonalBasisGradient_Line1_
+END INTERFACE OrthogonalBasisGradient_Line_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Line
!----------------------------------------------------------------------------
@@ -871,6 +1365,54 @@ MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans)
END FUNCTION HeirarchicalBasis_Line1
END INTERFACE HeirarchicalBasis_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Line_
+ MODULE SUBROUTINE HeirarchicalBasis_Line1_(order, xij, refLine, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Polynomial order of interpolation
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! This parameter denotes the type of reference line.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Line.
+ !! BIUNIT: in this case xij is in biunit Line.
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Hierarchical basis
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! SIZE(xij, 2), order + 1
+ END SUBROUTINE HeirarchicalBasis_Line1_
+END INTERFACE HeirarchicalBasis_Line_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Line_
+ MODULE SUBROUTINE HeirarchicalBasis_Line2_(order, xij, refLine, orient, &
+ ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Polynomial order of interpolation
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! This parameter denotes the type of reference line.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Line.
+ !! BIUNIT: in this case xij is in biunit Line.
+ INTEGER(I4B), INTENT(IN) :: orient
+ !! orientation of line: 1 or -1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Hierarchical basis
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! SIZE(xij, 2), order + 1
+ END SUBROUTINE HeirarchicalBasis_Line2_
+END INTERFACE HeirarchicalBasis_Line_
+
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Line
!----------------------------------------------------------------------------
@@ -879,11 +1421,9 @@ END FUNCTION HeirarchicalBasis_Line1
! date: 27 Oct 2022
! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line
-INTERFACE HeirarchicalGradientBasis_Line
- MODULE FUNCTION HeirarchicalGradientBasis_Line1( &
- & order, &
- & xij, &
- & refLine) RESULT(ans)
+INTERFACE HeirarchicalBasisGradient_Line
+ MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Polynomial order of interpolation
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -897,7 +1437,82 @@ MODULE FUNCTION HeirarchicalGradientBasis_Line1( &
REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1)
!! Gradient of Hierarchical basis
END FUNCTION HeirarchicalGradientBasis_Line1
-END INTERFACE HeirarchicalGradientBasis_Line
+END INTERFACE HeirarchicalBasisGradient_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Line_
+ MODULE SUBROUTINE HeirarchicalGradientBasis_Line1_(order, xij, refLine, &
+ ans, dim1, dim2, dim3)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Polynomial order of interpolation
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
+ !! size(xij, 1) should be 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! This parameter denotes the type of reference line.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Line.
+ !! BIUNIT: in this case xij is in biunit Line.
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Gradient of Hierarchical basis
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! SIZE(xij, 2), order + 1, 1
+ END SUBROUTINE HeirarchicalGradientBasis_Line1_
+END INTERFACE HeirarchicalBasisGradient_Line_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Line
+ MODULE FUNCTION HeirarchicalGradientBasis_Line2(order, xij, refLine, &
+ orient) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Polynomial order of interpolation
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
+ !! size(xij, 1) should be 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! This parameter denotes the type of reference line.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Line.
+ !! BIUNIT: in this case xij is in biunit Line.
+ INTEGER(I4B), INTENT(IN) :: orient
+ !! orientation of line: 1 or -1
+ REAL(DFP), ALLOCATABLE :: ans(:, :, :)
+ !! Gradient of Hierarchical basis
+ !! SIZE(xij, 2), order + 1, 1
+ END FUNCTION HeirarchicalGradientBasis_Line2
+END INTERFACE HeirarchicalBasisGradient_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Line_
+ MODULE SUBROUTINE HeirarchicalGradientBasis_Line2_(order, xij, refLine, &
+ orient, ans, dim1, dim2, dim3)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Polynomial order of interpolation
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
+ !! size(xij, 1) should be 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! This parameter denotes the type of reference line.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Line.
+ !! BIUNIT: in this case xij is in biunit Line.
+ INTEGER(I4B), INTENT(IN) :: orient
+ !! orientation of line: 1 or -1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Gradient of Hierarchical basis
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! SIZE(xij, 2), order + 1, 1
+ END SUBROUTINE HeirarchicalGradientBasis_Line2_
+END INTERFACE HeirarchicalBasisGradient_Line_
!----------------------------------------------------------------------------
! BasisGradientEvalAll_Line
@@ -908,14 +1523,8 @@ END FUNCTION HeirarchicalGradientBasis_Line1
! summary: Evaluate the gradient of basis functions of order upto n
INTERFACE BasisGradientEvalAll_Line
- MODULE FUNCTION BasisGradientEvalAll_Line1( &
- & order, &
- & x, &
- & refLine, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION BasisGradientEvalAll_Line1(order, x, refLine, basisType, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomials
REAL(DFP), INTENT(IN) :: x
@@ -923,12 +1532,7 @@ MODULE FUNCTION BasisGradientEvalAll_Line1( &
CHARACTER(*), INTENT(IN) :: refLine
!! Refline should be BIUNIT
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Monomial
- !! Jacobi
- !! Ultraspherical
- !! Legendre
- !! Chebyshev
- !! Lobatto
+ !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev ! Lobatto
!! UnscaledLobatto
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi polynomial parameter
@@ -941,6 +1545,36 @@ MODULE FUNCTION BasisGradientEvalAll_Line1( &
END FUNCTION BasisGradientEvalAll_Line1
END INTERFACE BasisGradientEvalAll_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE BasisGradientEvalAll_Line_
+ MODULE SUBROUTINE BasisGradientEvalAll_Line1_(order, x, refLine, &
+ basisType, alpha, beta, lambda, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: x
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(order + 1)
+ !! Value of n+1 polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! order + 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! Refline should be BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev
+ !! Lobatto ! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE BasisGradientEvalAll_Line1_
+END INTERFACE BasisGradientEvalAll_Line_
+
!----------------------------------------------------------------------------
! BasisEvalAll_Line
!----------------------------------------------------------------------------
@@ -950,29 +1584,17 @@ END FUNCTION BasisGradientEvalAll_Line1
! summary: Evaluate gradient of basis functions of order upto n
INTERFACE BasisGradientEvalAll_Line
- MODULE FUNCTION BasisGradientEvalAll_Line2( &
- & order, &
- & x, &
- & refLine, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION BasisGradientEvalAll_Line2(order, x, refLine, basisType, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomials
REAL(DFP), INTENT(IN) :: x(:)
!! point of evaluation
CHARACTER(*), INTENT(IN) :: refLine
- !! UNIT
- !! BIUNIT
+ !! UNIT ! BIUNIT
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Monomial
- !! Jacobi
- !! Ultraspherical
- !! Legendre
- !! Chebyshev
- !! Lobatto
- !! UnscaledLobatto
+ !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev
+ !! Lobatto ! UnscaledLobatto
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
@@ -986,6 +1608,39 @@ MODULE FUNCTION BasisGradientEvalAll_Line2( &
END FUNCTION BasisGradientEvalAll_Line2
END INTERFACE BasisGradientEvalAll_Line
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE BasisGradientEvalAll_Line_
+ MODULE SUBROUTINE BasisGradientEvalAll_Line2_(order, x, ans, nrow, ncol, &
+ refLine, basisType, alpha, beta, lambda)
+
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomials
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), order + 1)
+ !! Value of n+1 polynomials at point x
+ !! ans(:, j) is the value of jth polynomial at x points
+ !! ans(i, :) is the value of all polynomials at x(i) point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written to ans
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial ! Jacobi ! Ultraspherical ! Legendre ! Chebyshev
+ !! Lobatto ! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE BasisGradientEvalAll_Line2_
+END INTERFACE BasisGradientEvalAll_Line_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Line
!----------------------------------------------------------------------------
@@ -993,31 +1648,23 @@ END FUNCTION BasisGradientEvalAll_Line2
!> author: Vikas Sharma, Ph. D.
! date: 2023-07-19
! summary: Returns quadrature points
+!
+!# Introduction
+!
+! This function calls QuadraturePoint_Line3 function
INTERFACE QuadraturePoint_Line
- MODULE FUNCTION QuadraturePoint_Line1( &
- & order, &
- & quadType, &
- & layout, &
- & xij, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
- !!
+ MODULE FUNCTION QuadraturePoint_Line1(order, quadType, layout, xij, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of interpolation
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature point type
- !! Equidistance,
- !! GaussLegendre,
- !! GaussLegendreLobatto,
- !! GaussChebyshev,
- !! GaussChebyshevLobatto,
- !! GaussJacobi,
+ !! Equidistance, ! GaussLegendre, ! GaussLegendreLobatto,
+ !! GaussChebyshev, ! GaussChebyshevLobatto, ! GaussJacobi,
!! GaussJacobiLobatto
CHARACTER(*), INTENT(IN) :: layout
- !! "VEFC"
- !! "INCREASING"
+ !! "VEFC" ! "INCREASING"
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! domain of interpolation
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
@@ -1044,27 +1691,20 @@ END FUNCTION QuadraturePoint_Line1
!> author: Vikas Sharma, Ph. D.
! date: 27 Aug 2022
! summary: Returns the interpolation point
+!
+!# Introduction
+!
+! This function calls QuadraturePoint_Line1 function
INTERFACE QuadraturePoint_Line
- MODULE FUNCTION QuadraturePoint_Line2( &
- & order, &
- & quadType, &
- & xij, &
- & layout, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Line2(order, quadType, xij, layout, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of interpolation
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature point type
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussChebyshev,
- !! GaussChebyshevLobatto
- !! GaussJacobi
- !! GaussJacobiLobatto
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto ! GaussChebyshev,
+ !! GaussChebyshevLobatto ! GaussJacobi ! GaussJacobiLobatto
REAL(DFP), INTENT(IN) :: xij(2)
!! end points
CHARACTER(*), INTENT(IN) :: layout
@@ -1081,6 +1721,43 @@ MODULE FUNCTION QuadraturePoint_Line2( &
END FUNCTION QuadraturePoint_Line2
END INTERFACE QuadraturePoint_Line
+!----------------------------------------------------------------------------
+! QuadraturePoint_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Aug 2022
+! summary: Returns the interpolation point
+!
+!# Introduction
+!
+! This function calls QuadraturePoint_Line3
+
+INTERFACE QuadraturePoint_Line
+ MODULE FUNCTION QuadraturePoint_Line4(nips, quadType, xij, layout, &
+ alpha, beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! order of interpolation
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature point type
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto ! GaussChebyshev,
+ !! GaussChebyshevLobatto ! GaussJacobi ! GaussJacobiLobatto
+ REAL(DFP), INTENT(IN) :: xij(2)
+ !! end points
+ CHARACTER(*), INTENT(IN) :: layout
+ !! "VEFC"
+ !! "INCREASING"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! one dimensional interpolation point
+ END FUNCTION QuadraturePoint_Line4
+END INTERFACE QuadraturePoint_Line
+
!----------------------------------------------------------------------------
! QuadraturePoint_Line
!----------------------------------------------------------------------------
@@ -1090,15 +1767,8 @@ END FUNCTION QuadraturePoint_Line2
! summary: Returns quadrature points
INTERFACE QuadraturePoint_Line
- MODULE FUNCTION QuadraturePoint_Line3( &
- & nips, &
- & quadType, &
- & layout, &
- & xij, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
- !!
+ MODULE FUNCTION QuadraturePoint_Line3(nips, quadType, layout, xij, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: nips(1)
!! Order of interpolation
INTEGER(I4B), INTENT(IN) :: quadType
@@ -1133,47 +1803,42 @@ END FUNCTION QuadraturePoint_Line3
END INTERFACE QuadraturePoint_Line
!----------------------------------------------------------------------------
-! QuadraturePoint_Line
+!
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 27 Aug 2022
-! summary: Returns the interpolation point
+! date: 2024-07-07
+! summary: Quadrature point on line
-INTERFACE QuadraturePoint_Line
- MODULE FUNCTION QuadraturePoint_Line4( &
- & nips, &
- & quadType, &
- & xij, &
- & layout, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+INTERFACE QuadraturePoint_Line_
+ MODULE SUBROUTINE QuadraturePoint_Line1_(nips, quadType, layout, xij, &
+ alpha, beta, lambda, ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: nips(1)
- !! order of interpolation
+ !! Order of interpolation
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature point type
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussChebyshev,
- !! GaussChebyshevLobatto
- !! GaussJacobi
- !! GaussJacobiLobatto
- REAL(DFP), INTENT(IN) :: xij(2)
- !! end points
+ !! Equidistance, ! GaussLegendre, ! GaussLegendreLobatto, ! GaussChebyshev,
+ !! GaussChebyshevLobatto, ! GaussJacobi, ! GaussJacobiLobatto
CHARACTER(*), INTENT(IN) :: layout
- !! "VEFC"
- !! "INCREASING"
+ !! "VEFC" ! "INCREASING"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! domain of interpolation
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical parameter
- REAL(DFP), ALLOCATABLE :: ans(:, :)
- !! one dimensional interpolation point
- END FUNCTION QuadraturePoint_Line4
-END INTERFACE QuadraturePoint_Line
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! quadrature points
+ !! If xij is present then the number of rows in ans
+ !! is same as size(xij,1) + 1.
+ !! If xij is not present then the number of rows in
+ !! ans is 2
+ !! The last row of ans contains the weights
+ !! The first few rows contains the quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE QuadraturePoint_Line1_
+END INTERFACE QuadraturePoint_Line_
END MODULE LineInterpolationUtility
diff --git a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90
index 9d7e15c4e..a851dffd4 100644
--- a/src/modules/Polynomial/src/LobattoPolynomialUtility.F90
+++ b/src/modules/Polynomial/src/LobattoPolynomialUtility.F90
@@ -22,24 +22,137 @@
!{!pages/LobattoPolynomialUtility.md!}
MODULE LobattoPolynomialUtility
-USE GlobalData
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+USE BaseType, ONLY: iface_1DFunction
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: LobattoLeadingCoeff
PUBLIC :: LobattoZeros
PUBLIC :: LobattoEval
PUBLIC :: LobattoEvalAll
+PUBLIC :: LobattoEvalAll_
PUBLIC :: LobattoKernelEvalAll
PUBLIC :: LobattoKernelEvalAll_
PUBLIC :: LobattoKernelGradientEvalAll
PUBLIC :: LobattoKernelGradientEvalAll_
PUBLIC :: LobattoMonomialExpansionAll
PUBLIC :: LobattoMonomialExpansion
+
PUBLIC :: LobattoGradientEvalAll
+PUBLIC :: LobattoGradientEvalAll_
+
PUBLIC :: LobattoGradientEval
PUBLIC :: LobattoMassMatrix
PUBLIC :: LobattoStiffnessMatrix
+PUBLIC :: LobattoTransform_
+
+PUBLIC :: Lobatto0, Lobatto1, Lobatto2, Lobatto3, Lobatto4, Lobatto5
+
+PUBLIC :: Lobatto6, Lobatto7, Lobatto8, Lobatto9, Lobatto10
+
+!----------------------------------------------------------------------------
+! LobattoTransform_
+!----------------------------------------------------------------------------
+
+INTERFACE LobattoTransform_
+ MODULE SUBROUTINE LobattoTransform1_(n, coeff, PP, w, quadType, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! Order of Legendre polynomials
+ !! n+1 coefficient (modal values)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! Value of function at quadrature points
+ !! size of coeff is number of quadrature points
+ REAL(DFP), INTENT(IN) :: PP(0:, 0:)
+ !! Value of lobatto polynomials
+ !! PP(:, jj) value of Pjj at quadrature points
+ !! PP(ii, :) value of all lobatto polynomials at point ii
+ !! number of rows in PP is number of quadrature points
+ !! number of columns in PP is n+1
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! Weights for each quadrature points
+ !! size of w is number of quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type
+ !! Gauss, GaussLobatto, GaussRadau, GaussRadauLeft GaussRadauRight
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients of Legendre polynomial
+ !! ans(0) is coefficient of P0
+ !! ans(1) is coefficient of P1
+ !! and so on
+ ! REAL(DFP) :: ans(0:n)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size of ans
+ END SUBROUTINE LobattoTransform1_
+END INTERFACE LobattoTransform_
+
+!----------------------------------------------------------------------------
+! LobattoTransform_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-20
+! summary: LobattoTransform
+
+INTERFACE LobattoTransform_
+ MODULE SUBROUTINE LobattoTransform2_(n, coeff, x, w, quadType, ans, &
+ tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! Order of Lobatto polynomials
+ !! n+1 coefficient (modal values)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
+ !! Value of function at quadrature points
+ REAL(DFP), INTENT(IN) :: x(0:)
+ !! Quadrature points
+ !! These quadrature points are used in LobattoEvalAll method
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! Weights
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
+ !! GaussRadauRight
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients of Lobatto polynomial
+ !! ans(0) is coefficient of P0
+ !! ans(1) is coefficient of P1
+ !! and so on
+ ! REAL(DFP) :: ans(0:n)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size of ans
+ END SUBROUTINE LobattoTransform2_
+END INTERFACE LobattoTransform_
+
+!----------------------------------------------------------------------------
+! LobattoTransform_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-20
+! summary: LobattoTransform of function
+
+INTERFACE LobattoTransform_
+ MODULE SUBROUTINE LobattoTransform3_(n, f, quadType, x1, x2, ans, tsize)
+ 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
+ !! We will use Legendre quadrature points
+ REAL(DFP), INTENT(IN) :: x1, x2
+ !! domain of function f
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! modal values or coefficients
+ !! ans(0:n)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! n+1
+ END SUBROUTINE LobattoTransform3_
+END INTERFACE LobattoTransform_
+
!----------------------------------------------------------------------------
! LobattoLeadingCoeff
!----------------------------------------------------------------------------
@@ -109,17 +222,13 @@ END FUNCTION LobattoZeros
!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point
! X.
-INTERFACE
+INTERFACE LobattoEval
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
!----------------------------------------------------------------------------
@@ -141,17 +250,13 @@ END FUNCTION LobattoEval1
!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point
! X.
-INTERFACE
+INTERFACE LobattoEval
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
!----------------------------------------------------------------------------
@@ -173,7 +278,7 @@ END FUNCTION LobattoEval2
!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point
! X.
-INTERFACE
+INTERFACE LobattoEvalAll
MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
REAL(DFP), INTENT(IN) :: x
@@ -181,12 +286,24 @@ MODULE PURE FUNCTION LobattoEvalAll1(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! LobattoEvalAll_
+!----------------------------------------------------------------------------
+
+INTERFACE LobattoEvalAll_
+ MODULE PURE SUBROUTINE LobattoEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(n + 1)
+ !! Evaluate Lobatto polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LobattoEvalAll1_
+END INTERFACE LobattoEvalAll_
+
!----------------------------------------------------------------------------
! LobattoEvalAll
!----------------------------------------------------------------------------
@@ -206,7 +323,7 @@ END FUNCTION LobattoEvalAll1
!- ans(M,1:N+1), the values of the first N+1 Lobatto polynomials at the point
! X.
-INTERFACE
+INTERFACE LobattoEvalAll
MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
REAL(DFP), INTENT(IN) :: x(:)
@@ -214,12 +331,24 @@ MODULE PURE FUNCTION LobattoEvalAll2(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! LobattoEvalAll_
+!----------------------------------------------------------------------------
+
+INTERFACE LobattoEvalAll_
+ MODULE PURE SUBROUTINE LobattoEvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(x), n + 1)
+ !! Evaluate Lobatto polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LobattoEvalAll2_
+END INTERFACE LobattoEvalAll_
+
!----------------------------------------------------------------------------
! LobattoKernelEvalAll
!----------------------------------------------------------------------------
@@ -393,6 +522,20 @@ END FUNCTION LobattoGradientEvalAll1
!
!----------------------------------------------------------------------------
+INTERFACE LobattoGradientEvalAll_
+ MODULE PURE SUBROUTINE LobattoGradientEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(1:n + 1)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LobattoGradientEvalAll1_
+END INTERFACE LobattoGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of Lobatto polynomial of order upto n
@@ -413,6 +556,20 @@ END FUNCTION LobattoGradientEvalAll2
!
!----------------------------------------------------------------------------
+INTERFACE LobattoGradientEvalAll_
+ MODULE PURE SUBROUTINE LobattoGradientEvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ ! ans(1:SIZE(x), 1:n + 1)
+ END SUBROUTINE LobattoGradientEvalAll2_
+END INTERFACE LobattoGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of Lobatto polynomial of order upto n
@@ -421,18 +578,14 @@ END FUNCTION LobattoGradientEvalAll2
!
! Evaluate gradient of Lobatto polynomial of order upto n.
-INTERFACE
+INTERFACE LobattoGradientEval
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
+!!
!----------------------------------------------------------------------------
!
@@ -446,16 +599,12 @@ END FUNCTION LobattoGradientEval1
!
! Evaluate gradient of Lobatto polynomial of order upto n.
-INTERFACE
+INTERFACE LobattoGradientEval
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
!----------------------------------------------------------------------------
@@ -488,6 +637,127 @@ MODULE PURE FUNCTION LobattoStiffnessMatrix(n) RESULT(ans)
END FUNCTION LobattoStiffnessMatrix
END INTERFACE
+!----------------------------------------------------------------------------
+! Lobatto0
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto0(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto0
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto1
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto1(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto1
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto2
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto2(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto2
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto3
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto3(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto3
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto4
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto4(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto4
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto5
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto5(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto5
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto6
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto6(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto6
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto7
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto7(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto7
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto8
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto8(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto8
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto9
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto9(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto9
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! Lobatto10
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE FUNCTION Lobatto10(x) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP) :: ans
+ END FUNCTION Lobatto10
+END INTERFACE
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90 b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90
index 5e4783126..bec4626ac 100644
--- a/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90
+++ b/src/modules/Polynomial/src/OrthogonalPolynomialUtility.F90
@@ -16,20 +16,33 @@
!
MODULE OrthogonalPolynomialUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: Clenshaw
PUBLIC :: ChebClenshaw
PUBLIC :: JacobiMatrix
+
PUBLIC :: EvalAllOrthopol
+PUBLIC :: EvalAllOrthopol_
+
PUBLIC :: GradientEvalAllOrthopol
+PUBLIC :: GradientEvalAllOrthopol_
+
+PUBLIC :: OrthogonalEvalAll_
+PUBLIC :: OrthogonalEvalAll
+
+PUBLIC :: OrthogonalGradientEvalAll_
+PUBLIC :: OrthogonalGradientEvalAll
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE Clenshaw
MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: x
REAL(DFP), INTENT(IN) :: alpha(0:)
@@ -41,17 +54,13 @@ MODULE PURE FUNCTION Clenshaw_1(x, alpha, beta, y0, ym1, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: c(0:)
REAL(DFP) :: ans
END FUNCTION Clenshaw_1
-END INTERFACE
-
-INTERFACE Clenshaw
- MODULE PROCEDURE Clenshaw_1
END INTERFACE Clenshaw
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE Clenshaw
MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: x(:)
REAL(DFP), INTENT(IN) :: alpha(0:)
@@ -63,10 +72,6 @@ MODULE PURE FUNCTION Clenshaw_2(x, alpha, beta, y0, ym1, c) RESULT(ans)
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,22 +90,14 @@ END FUNCTION Clenshaw_2
! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x)
!$$
-INTERFACE
+INTERFACE Clenshaw
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
- MODULE PROCEDURE ChebClenshaw_1
END INTERFACE Clenshaw
-INTERFACE ChebClenshaw
- MODULE PROCEDURE ChebClenshaw_1
-END INTERFACE ChebClenshaw
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -117,16 +114,12 @@ END FUNCTION ChebClenshaw_1
! s(t) = 0.5 c_{0} + \sum_{i=1}^{n} c_{i} T_{j}(x)
!$$
-INTERFACE
+INTERFACE Clenshaw
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
- MODULE PROCEDURE ChebClenshaw_2
END INTERFACE Clenshaw
INTERFACE ChebClenshaw
@@ -137,7 +130,7 @@ END FUNCTION ChebClenshaw_2
! JacobiMatrix
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE JacobiMatrix
MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E)
REAL(DFP), INTENT(IN) :: alphaCoeff(0:)
!! size n, from 0 to n-1
@@ -148,10 +141,6 @@ MODULE PURE SUBROUTINE JacobiMatrix_1(alphaCoeff, betaCoeff, D, E)
REAL(DFP), INTENT(OUT) :: E(:)
!! entry from 1 to n-1 are filled
END SUBROUTINE JacobiMatrix_1
-END INTERFACE
-
-INTERFACE JacobiMatrix
- MODULE PROCEDURE JacobiMatrix_1
END INTERFACE JacobiMatrix
!----------------------------------------------------------------------------
@@ -160,18 +149,14 @@ END SUBROUTINE JacobiMatrix_1
INTERFACE
MODULE PURE FUNCTION EvalAllOrthopol(n, x, orthopol, alpha, beta, &
- & lambda) RESULT(ans)
+ 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
- !! Legendre
- !! Jacobi
- !! Lobatto
- !! Chebyshev
- !! Ultraspherical
+ !! Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! alpha1 needed when orthopol1 is "Jacobi"
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
@@ -192,22 +177,15 @@ END FUNCTION EvalAllOrthopol
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE FUNCTION GradientEvalAllOrthopol( &
- & n, &
- & x, &
- & orthopol, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE PURE FUNCTION GradientEvalAllOrthopol(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
- !! Legendre
- !! Jacobi
- !! Lobatto
- !! Chebyshev
- !! Ultraspherical
+ !! Orthogonal polynomial family
+ !! Legendre Jacobi Lobatto Chebyshev Ultraspherical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! alpha1 needed when orthopol1 is "Jacobi"
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
@@ -223,4 +201,218 @@ MODULE PURE FUNCTION GradientEvalAllOrthopol( &
END FUNCTION GradientEvalAllOrthopol
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE GradientEvalAllOrthopol_(n, x, orthopol, ans, &
+ nrow, ncol, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! points of evaluation
+ INTEGER(I4B), INTENT(IN) :: orthopol
+ !! Orthogonal polynomial family
+ !! Legendre Jacobi Lobatto Chebyshev Ultraspherical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), n + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! The number of rows in ans is equal to the number of points.
+ !! The number of columns are equal to the orthogonal
+ !! polynomials from order = 0 to n
+ !! Therefore, jth column is denotes the value of jth polynomial
+ !! at all the points.
+ 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"
+ END SUBROUTINE GradientEvalAllOrthopol_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! EvalAllOrthopol_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE EvalAllOrthopol_(n, x, orthopol, alpha, beta, &
+ lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! points of evaluation
+ INTEGER(I4B), INTENT(IN) :: orthopol
+ !! orthogonal polynomial family
+ !! Legendre Jacobi ! Lobatto ! Chebyshev ! Ultraspherical
+ 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), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(x), n + 1)
+ !! The number of rows in ans is equal to the number of points.
+ !! The number of columns are equal to the orthogonal
+ !! polynomials from order = 0 to n
+ !! Therefore, jth column is denotes the value of jth polynomial
+ !! at all the points.
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE EvalAllOrthopol_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! OrthogonalEvalAll
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-09-10
+! summary: Evaluate orthogonal polynomials
+
+INTERFACE
+ MODULE FUNCTION OrthogonalEvalAll(order, elemType, xij, domainName, &
+ basisType, alpha, beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ !! used for line, quadrangle, and hexahedron element
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! alpha needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! beta is needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! lambda is needed when orthopol1 is "Ultraspherical"
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! Value of n+1 Orthogonal polynomials at point x
+ END FUNCTION OrthogonalEvalAll
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! OrthogonalGradientEvalAll
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-09-10
+! summary: Evaluate orthogonal polynomials
+
+INTERFACE
+ MODULE SUBROUTINE OrthogonalEvalAll_(order, elemType, xij, domainName, &
+ basisType, ans, nrow, ncol, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ !! used for line, quadrangle, and hexahedron element
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! alpha needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! beta is needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! lambda is needed when orthopol1 is "Ultraspherical"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 Orthogonal polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and cols in ans
+ END SUBROUTINE OrthogonalEvalAll_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! OrthogonalGradientEvalAll
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-09-10
+! summary: Evaluate orthogonal polynomials
+
+INTERFACE
+ MODULE FUNCTION OrthogonalGradientEvalAll(order, elemType, xij, domainName, &
+ basisType, alpha, beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ !! used for line, quadrangle, and hexahedron element
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! alpha needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! beta is needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! lambda is needed when orthopol1 is "Ultraspherical"
+ REAL(DFP), ALLOCATABLE :: ans(:, :, :)
+ !! Value of n+1 Orthogonal polynomials at point x
+ END FUNCTION OrthogonalGradientEvalAll
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! OrthogonalGradientEvalAll
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-09-10
+! summary: Evaluate orthogonal polynomials
+
+INTERFACE
+ MODULE SUBROUTINE OrthogonalGradientEvalAll_(order, elemType, xij, &
+ domainName, basisType, ans, dim1, dim2, dim3, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain of reference element
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basis type
+ !! used for line, quadrangle, and hexahedron element
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! alpha needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! beta is needed when orthopol1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! lambda is needed when orthopol1 is "Ultraspherical"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of n+1 Orthogonal polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! number of rows and cols in ans
+ END SUBROUTINE OrthogonalGradientEvalAll_
+END INTERFACE
+
END MODULE OrthogonalPolynomialUtility
diff --git a/src/modules/Polynomial/src/PolynomialUtility.F90 b/src/modules/Polynomial/src/PolynomialUtility.F90
index 362d8fcc0..2033e9cba 100644
--- a/src/modules/Polynomial/src/PolynomialUtility.F90
+++ b/src/modules/Polynomial/src/PolynomialUtility.F90
@@ -16,21 +16,22 @@
!
MODULE PolynomialUtility
+USE Chebyshev1PolynomialUtility
+USE HexahedronInterpolationUtility
+USE HierarchicalPolynomialUtility
USE InterpolationUtility
-USE LagrangePolynomialUtility
-USE OrthogonalPolynomialUtility
USE JacobiPolynomialUtility
-USE UltrasphericalPolynomialUtility
+USE LagrangePolynomialUtility
USE LegendrePolynomialUtility
-USE LobattoPolynomialUtility
-USE UnscaledLobattoPolynomialUtility
-USE Chebyshev1PolynomialUtility
USE LineInterpolationUtility
-USE TriangleInterpolationUtility
-USE QuadrangleInterpolationUtility
-USE TetrahedronInterpolationUtility
-USE HexahedronInterpolationUtility
+USE LobattoPolynomialUtility
+USE OrthogonalPolynomialUtility
USE PrismInterpolationUtility
USE PyramidInterpolationUtility
+USE QuadrangleInterpolationUtility
USE RecursiveNodesUtility
+USE TetrahedronInterpolationUtility
+USE TriangleInterpolationUtility
+USE UltrasphericalPolynomialUtility
+USE UnscaledLobattoPolynomialUtility
END MODULE PolynomialUtility
diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Polynomial/src/PrismInterpolationUtility.F90
index 40ced9a38..adebc985b 100644
--- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/PrismInterpolationUtility.F90
@@ -18,20 +18,31 @@
MODULE PrismInterpolationUtility
USE GlobalData
USE String_Class, ONLY: String
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: LagrangeDegree_Prism
PUBLIC :: LagrangeDOF_Prism
PUBLIC :: LagrangeInDOF_Prism
PUBLIC :: EquidistanceInPoint_Prism
+
PUBLIC :: EquidistancePoint_Prism
+PUBLIC :: EquidistancePoint_Prism_
+
PUBLIC :: InterpolationPoint_Prism
+PUBLIC :: InterpolationPoint_Prism_
PUBLIC :: LagrangeCoeff_Prism
+PUBLIC :: LagrangeCoeff_Prism_
PUBLIC :: QuadraturePoint_Prism
PUBLIC :: TensorQuadraturePoint_Prism
PUBLIC :: RefElemDomain_Prism
PUBLIC :: LagrangeEvalAll_Prism
+PUBLIC :: LagrangeEvalAll_Prism_
PUBLIC :: LagrangeGradientEvalAll_Prism
+PUBLIC :: LagrangeGradientEvalAll_Prism_
+
PUBLIC :: EdgeConnectivity_Prism
PUBLIC :: FacetConnectivity_Prism
PUBLIC :: GetTotalDOF_Prism
@@ -64,7 +75,7 @@ END FUNCTION GetTotalDOF_Prism
END INTERFACE
!----------------------------------------------------------------------------
-! LagrangeInDOF_Prism
+! LagrangeInDOF_Prism
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -248,16 +259,36 @@ END FUNCTION EquidistanceInPoint_Prism
INTERFACE
MODULE PURE FUNCTION EquidistancePoint_Prism(order, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
- !! order
+ !! order
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
- !! coordinates of point 1 and point 2 in $x_{iJ}$ format
- !! number of rows = nsd
- !! number of cols = 3
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 3
REAL(DFP), ALLOCATABLE :: ans(:, :)
- !! returned coordinates in $x_{iJ}$ format
+ !! returned coordinates in $x_{iJ}$ format
END FUNCTION EquidistancePoint_Prism
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE EquidistancePoint_Prism_(order, ans, nrow, ncol, &
+ xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! equidistance points in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 3
+ END SUBROUTINE EquidistancePoint_Prism_
+END INTERFACE
+
!----------------------------------------------------------------------------
! InterpolationPoint_Prism
!----------------------------------------------------------------------------
@@ -267,13 +298,8 @@ END FUNCTION EquidistancePoint_Prism
! summary: Interpolation point on Prism
INTERFACE
- MODULE PURE FUNCTION InterpolationPoint_Prism( &
- & order, &
- & ipType, &
- & layout, &
- & xij, &
- & alpha, beta, lambda) &
- & RESULT(nodecoord)
+ MODULE FUNCTION InterpolationPoint_Prism(order, ipType, layout, &
+ xij, alpha, beta, lambda) RESULT(nodecoord)
INTEGER(I4B), INTENT(IN) :: order
!! order
INTEGER(I4B), INTENT(IN) :: ipType
@@ -289,6 +315,33 @@ MODULE PURE FUNCTION InterpolationPoint_Prism( &
END FUNCTION InterpolationPoint_Prism
END INTERFACE
+!----------------------------------------------------------------------------
+! InterpolationPoint_Prism
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Interpolation point on Prism
+
+INTERFACE
+ MODULE SUBROUTINE InterpolationPoint_Prism_(order, ipType, ans, &
+ nrow, ncol, layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Interpolation point type
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolation points in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ CHARACTER(*), INTENT(IN) :: layout
+ !!
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coords of vertices in $x_{iJ}$ format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ !! Jacobi and Ultraspherical parameters
+ END SUBROUTINE InterpolationPoint_Prism_
+END INTERFACE
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Prism
!----------------------------------------------------------------------------
@@ -350,16 +403,123 @@ END FUNCTION LagrangeCoeff_Prism3
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Prism
- MODULE FUNCTION LagrangeCoeff_Prism4(order, xij) RESULT(ans)
+ MODULE FUNCTION LagrangeCoeff_Prism4(order, xij, basisType, &
+ refPrism, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial
REAL(DFP), INTENT(IN) :: xij(:, :)
!! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials
+ !! Jacobi (Dubiner)
+ !! Heirarchical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism
+ !! UNIT * default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2))
!! coefficients
END FUNCTION LagrangeCoeff_Prism4
END INTERFACE LagrangeCoeff_Prism
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Prism_
+ MODULE SUBROUTINE LagrangeCoeff_Prism1_(order, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Prism1_
+END INTERFACE LagrangeCoeff_Prism_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Prism_
+ MODULE SUBROUTINE LagrangeCoeff_Prism2_(order, i, v, isVandermonde, &
+ ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ ! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Prism2_
+END INTERFACE LagrangeCoeff_Prism_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Prism_
+ MODULE SUBROUTINE LagrangeCoeff_Prism3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Prism3_
+END INTERFACE LagrangeCoeff_Prism_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Prism_
+ MODULE SUBROUTINE LagrangeCoeff_Prism4_(order, xij, basisType, &
+ refPrism, alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials
+ !! Jacobi (Dubiner)
+ !! Heirarchical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism
+ !! UNIT * default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Prism4_
+END INTERFACE LagrangeCoeff_Prism_
+
!----------------------------------------------------------------------------
! QuadraturePoints_Prism
!----------------------------------------------------------------------------
@@ -494,10 +654,6 @@ MODULE FUNCTION TensorQuadraturePoint_Prism2( &
END FUNCTION TensorQuadraturePoint_Prism2
END INTERFACE TensorQuadraturePoint_Prism
-INTERFACE OrthogonalBasisGradient_Prism
- MODULE PROCEDURE TensorQuadraturePoint_Prism2
-END INTERFACE OrthogonalBasisGradient_Prism
-
!----------------------------------------------------------------------------
! LagrangeEvalAll_Prism
!----------------------------------------------------------------------------
@@ -561,6 +717,58 @@ MODULE FUNCTION LagrangeEvalAll_Prism1( &
END FUNCTION LagrangeEvalAll_Prism1
END INTERFACE LagrangeEvalAll_Prism
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Prism_
+ MODULE SUBROUTINE LagrangeEvalAll_Prism1_(order, x, xij, ans, tsize, &
+ refPrism, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(3)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ !! x(3) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ !! The number of rows in xij is 3
+ !! The number of columns in xij should be equal to total
+ !! degree of freedom
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! ans(SIZE(xij, 2))
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be computed and returned
+ !! by this routine.
+ !! If firstCall is False, then coeff should be given, which will be
+ !! used.
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Legendre
+ !! Lobatto
+ !! Chebyshev
+ !! Jacobi
+ !! Ultraspherical
+ !! Heirarchical
+ !! Orthogonal
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Prism1_
+END INTERFACE LagrangeEvalAll_Prism_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Prism
!----------------------------------------------------------------------------
@@ -620,6 +828,47 @@ MODULE FUNCTION LagrangeEvalAll_Prism2( &
END FUNCTION LagrangeEvalAll_Prism2
END INTERFACE LagrangeEvalAll_Prism
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Prism_
+ MODULE SUBROUTINE LagrangeEvalAll_Prism2_(order, x, xij, ans, nrow, ncol, &
+ refPrism, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 Lagrange polynomials at point x
+ !! ans(SIZE(x, 2), SIZE(xij, 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Prism2_
+END INTERFACE LagrangeEvalAll_Prism_
+
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Prism
!----------------------------------------------------------------------------
@@ -654,7 +903,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Prism1( &
!! UNIT *default
!! BIUNIT
REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
- !! Coefficient of Lagrange polynomials
+ !!!! Coefficient of Lagrange polynomials
LOGICAL(LGT), OPTIONAL :: firstCall
!! If firstCall is true, then coeff will be made
!! If firstCall is False, then coeff will be used
@@ -687,4 +936,50 @@ END FUNCTION LagrangeGradientEvalAll_Prism1
!
!----------------------------------------------------------------------------
+INTERFACE LagrangeGradientEvalAll_Prism_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Prism1_(order, x, xij, ans, &
+ dim1, dim2, dim3, refPrism, coeff, firstCall, basisType, alpha, beta, &
+ lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! SIZE(x, 2), SIZE(xij, 2), 3
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPrism
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default ! Legendre ! Lobatto ! Chebyshev ! Jacobi
+ !! Ultraspherical ! Heirarchical ! Orthogonal
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Prism1_
+END INTERFACE LagrangeGradientEvalAll_Prism_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE PrismInterpolationUtility
diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90
index 12147960d..ba78b888e 100644
--- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/PyramidInterpolationUtility.F90
@@ -25,13 +25,18 @@ MODULE PyramidInterpolationUtility
PUBLIC :: LagrangeInDOF_Pyramid
PUBLIC :: EquidistanceInPoint_Pyramid
PUBLIC :: EquidistancePoint_Pyramid
+PUBLIC :: EquidistancePoint_Pyramid_
PUBLIC :: InterpolationPoint_Pyramid
+PUBLIC :: InterpolationPoint_Pyramid_
PUBLIC :: LagrangeCoeff_Pyramid
+PUBLIC :: LagrangeCoeff_Pyramid_
PUBLIC :: QuadraturePoint_Pyramid
PUBLIC :: TensorQuadraturePoint_Pyramid
PUBLIC :: RefElemDomain_Pyramid
PUBLIC :: LagrangeEvalAll_Pyramid
+PUBLIC :: LagrangeEvalAll_Pyramid_
PUBLIC :: LagrangeGradientEvalAll_Pyramid
+PUBLIC :: LagrangeGradientEvalAll_Pyramid_
PUBLIC :: EdgeConnectivity_Pyramid
PUBLIC :: FacetConnectivity_Pyramid
PUBLIC :: GetTotalDOF_Pyramid
@@ -258,6 +263,26 @@ MODULE PURE FUNCTION EquidistancePoint_Pyramid(order, xij) RESULT(ans)
END FUNCTION EquidistancePoint_Pyramid
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE EquidistancePoint_Pyramid_(order, ans, nrow, ncol, &
+ xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 3
+ END SUBROUTINE EquidistancePoint_Pyramid_
+END INTERFACE
+
!----------------------------------------------------------------------------
! InterpolationPoint_Pyramid
!----------------------------------------------------------------------------
@@ -267,12 +292,8 @@ END FUNCTION EquidistancePoint_Pyramid
! summary: Interpolation point on Pyramid
INTERFACE
- MODULE PURE FUNCTION InterpolationPoint_Pyramid( &
- & order, &
- & ipType, &
- & layout, &
- & xij, &
- & alpha, beta, lambda) RESULT(nodecoord)
+ MODULE FUNCTION InterpolationPoint_Pyramid(order, ipType, layout, &
+ xij, alpha, beta, lambda) RESULT(nodecoord)
INTEGER(I4B), INTENT(IN) :: order
!! order of element
INTEGER(I4B), INTENT(IN) :: ipType
@@ -289,10 +310,38 @@ END FUNCTION InterpolationPoint_Pyramid
END INTERFACE
!----------------------------------------------------------------------------
-! LagrangeCoeff_Pyramid
+! InterpolationPoint_Pyramid
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Interpolation point on Pyramid
+
INTERFACE
+ MODULE SUBROUTINE InterpolationPoint_Pyramid_(order, ipType, ans, &
+ nrow, ncol, layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of element
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ CHARACTER(*), INTENT(IN) :: layout
+ !! layout
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coords of vertices in $x_{iJ}$ format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ !! Alpha, beta, and lambda
+ END SUBROUTINE InterpolationPoint_Pyramid_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Pyramid
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Pyramid
MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial
@@ -303,17 +352,13 @@ MODULE FUNCTION LagrangeCoeff_Pyramid1(order, i, xij) RESULT(ans)
REAL(DFP) :: ans(SIZE(xij, 2))
!! coefficients
END FUNCTION LagrangeCoeff_Pyramid1
-END INTERFACE
-
-INTERFACE LagrangeCoeff_Pyramid
- MODULE PROCEDURE LagrangeCoeff_Pyramid1
END INTERFACE LagrangeCoeff_Pyramid
!----------------------------------------------------------------------------
! LagrangeCoeff_Pyramid
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE LagrangeCoeff_Pyramid
MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
@@ -327,17 +372,13 @@ MODULE FUNCTION LagrangeCoeff_Pyramid2(order, i, v, isVandermonde) &
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
+INTERFACE LagrangeCoeff_Pyramid
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
@@ -350,31 +391,130 @@ MODULE FUNCTION LagrangeCoeff_Pyramid3(order, i, v, ipiv) RESULT(ans)
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)
+INTERFACE LagrangeCoeff_Pyramid
+ MODULE FUNCTION LagrangeCoeff_Pyramid4(order, xij, basisType, &
+ refPyramid, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial
REAL(DFP), INTENT(IN) :: xij(:, :)
!! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials
+ !! Jacobi (Dubiner)
+ !! Heirarchical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid
+ !! UNIT * default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
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
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Pyramid_
+ MODULE SUBROUTINE LagrangeCoeff_Pyramid1_(order, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Pyramid1_
+END INTERFACE LagrangeCoeff_Pyramid_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Pyramid_
+ MODULE SUBROUTINE LagrangeCoeff_Pyramid2_(order, i, v, isVandermonde, &
+ ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ ! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Pyramid2_
+END INTERFACE LagrangeCoeff_Pyramid_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Pyramid_
+ MODULE SUBROUTINE LagrangeCoeff_Pyramid3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Pyramid3_
+END INTERFACE LagrangeCoeff_Pyramid_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Pyramid_
+ MODULE SUBROUTINE LagrangeCoeff_Pyramid4_(order, xij, basisType, &
+ refPyramid, alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials
+ !! Jacobi (Dubiner)
+ !! Heirarchical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid
+ !! UNIT * default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Pyramid4_
+END INTERFACE LagrangeCoeff_Pyramid_
+
!----------------------------------------------------------------------------
! QuadraturePoints_Pyramid
!----------------------------------------------------------------------------
@@ -572,6 +712,58 @@ MODULE FUNCTION LagrangeEvalAll_Pyramid1( &
END FUNCTION LagrangeEvalAll_Pyramid1
END INTERFACE LagrangeEvalAll_Pyramid
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Pyramid_
+ MODULE SUBROUTINE LagrangeEvalAll_Pyramid1_(order, x, xij, ans, tsize, &
+ refPyramid, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(3)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ !! x(3) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ !! The number of rows in xij is 3
+ !! The number of columns in xij should be equal to total
+ !! degree of freedom
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! ans(SIZE(xij, 2))
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be computed and returned
+ !! by this routine.
+ !! If firstCall is False, then coeff should be given, which will be
+ !! used.
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Legendre
+ !! Lobatto
+ !! Chebyshev
+ !! Jacobi
+ !! Ultraspherical
+ !! Heirarchical
+ !! Orthogonal
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Pyramid1_
+END INTERFACE LagrangeEvalAll_Pyramid_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Pyramid
!----------------------------------------------------------------------------
@@ -631,6 +823,54 @@ MODULE FUNCTION LagrangeEvalAll_Pyramid2( &
END FUNCTION LagrangeEvalAll_Pyramid2
END INTERFACE LagrangeEvalAll_Pyramid
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Pyramid_
+ MODULE SUBROUTINE LagrangeEvalAll_Pyramid2_(order, x, xij, ans, nrow, &
+ ncol, refPyramid, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x, 2),
+ !! ncol = SIZE(xij, 2)
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Legendre
+ !! Lobatto
+ !! Chebyshev
+ !! Jacobi
+ !! Ultraspherical
+ !! Heirarchical
+ !! Orthogonal
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Pyramid2_
+END INTERFACE LagrangeEvalAll_Pyramid_
+
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Pyramid
!----------------------------------------------------------------------------
@@ -698,4 +938,49 @@ END FUNCTION LagrangeGradientEvalAll_Pyramid1
!
!----------------------------------------------------------------------------
+INTERFACE LagrangeGradientEvalAll_Pyramid_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Pyramid1_(order, x, xij, ans, &
+ dim1, dim2, dim3, refPyramid, coeff, firstCall, basisType, alpha, &
+ beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! (SIZE(x, 2), SIZE(xij, 2), 3
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refPyramid
+ !! UNIT *default ! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default ! Legendre ! Lobatto ! Chebyshev ! Jacobi
+ !! Ultraspherical ! Heirarchical ! Orthogonal
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Pyramid1_
+END INTERFACE LagrangeGradientEvalAll_Pyramid_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE PyramidInterpolationUtility
diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90
index 20109601e..05a408880 100644
--- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90
@@ -1,4 +1,4 @@
-! 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
@@ -17,37 +17,72 @@
MODULE QuadrangleInterpolationUtility
USE GlobalData
USE String_Class, ONLY: String
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: LagrangeDegree_Quadrangle
PUBLIC :: LagrangeDOF_Quadrangle
PUBLIC :: LagrangeInDOF_Quadrangle
+
PUBLIC :: EquidistancePoint_Quadrangle
+PUBLIC :: EquidistancePoint_Quadrangle_
+
PUBLIC :: EquidistanceInPoint_Quadrangle
+
PUBLIC :: InterpolationPoint_Quadrangle
+PUBLIC :: InterpolationPoint_Quadrangle_
+
PUBLIC :: LagrangeCoeff_Quadrangle
+PUBLIC :: LagrangeCoeff_Quadrangle_
+
PUBLIC :: Dubiner_Quadrangle
PUBLIC :: Dubiner_Quadrangle_
+
+PUBLIC :: DubinerGradient_Quadrangle
+PUBLIC :: DubinerGradient_Quadrangle_
+
PUBLIC :: TensorProdBasis_Quadrangle
+
PUBLIC :: OrthogonalBasis_Quadrangle
+PUBLIC :: OrthogonalBasis_Quadrangle_
+
PUBLIC :: VertexBasis_Quadrangle
+
PUBLIC :: VerticalEdgeBasis_Quadrangle
+
PUBLIC :: HorizontalEdgeBasis_Quadrangle
+
PUBLIC :: CellBasis_Quadrangle
+
PUBLIC :: HeirarchicalBasis_Quadrangle
+PUBLIC :: HeirarchicalBasis_Quadrangle_
+
PUBLIC :: IJ2VEFC_Quadrangle_Clockwise
PUBLIC :: IJ2VEFC_Quadrangle_AntiClockwise
+
PUBLIC :: LagrangeEvalAll_Quadrangle
+PUBLIC :: LagrangeEvalAll_Quadrangle_
+
PUBLIC :: QuadraturePoint_Quadrangle
+PUBLIC :: QuadraturePoint_Quadrangle_
PUBLIC :: QuadratureNumber_Quadrangle
+
PUBLIC :: FacetConnectivity_Quadrangle
PUBLIC :: RefElemDomain_Quadrangle
+
PUBLIC :: LagrangeGradientEvalAll_Quadrangle
+PUBLIC :: LagrangeGradientEvalAll_Quadrangle_
+
PUBLIC :: HeirarchicalBasisGradient_Quadrangle
+PUBLIC :: HeirarchicalBasisGradient_Quadrangle_
+
PUBLIC :: TensorProdBasisGradient_Quadrangle
+
PUBLIC :: OrthogonalBasisGradient_Quadrangle
-PUBLIC :: DubinerGradient_Quadrangle
-PUBLIC :: DubinerGradient_Quadrangle_
+PUBLIC :: OrthogonalBasisGradient_Quadrangle_
+
PUBLIC :: GetTotalDOF_Quadrangle
PUBLIC :: GetTotalInDOF_Quadrangle
@@ -85,15 +120,29 @@ END FUNCTION GetTotalDOF_Quadrangle
! lagrange polynomial on an edge of a Quadrangle
!- These dof are strictly inside the Quadrangle
-INTERFACE
- MODULE PURE FUNCTION GetTotalInDOF_Quadrangle(order, baseContinuity, &
+INTERFACE GetTotalInDOF_Quadrangle
+ MODULE PURE FUNCTION GetTotalInDOF_Quadrangle1(order, baseContinuity, &
baseInterpolation) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
CHARACTER(*), INTENT(IN) :: baseContinuity
CHARACTER(*), INTENT(IN) :: baseInterpolation
INTEGER(I4B) :: ans
- END FUNCTION GetTotalInDOF_Quadrangle
-END INTERFACE
+ END FUNCTION GetTotalInDOF_Quadrangle1
+END INTERFACE GetTotalInDOF_Quadrangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE GetTotalInDOF_Quadrangle
+ MODULE PURE FUNCTION GetTotalInDOF_Quadrangle2(p, q, baseContinuity, &
+ baseInterpolation) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: p, q
+ CHARACTER(*), INTENT(IN) :: baseContinuity
+ CHARACTER(*), INTENT(IN) :: baseInterpolation
+ INTEGER(I4B) :: ans
+ END FUNCTION GetTotalInDOF_Quadrangle2
+END INTERFACE GetTotalInDOF_Quadrangle
!----------------------------------------------------------------------------
! RefElemDomain_Quadrangle
@@ -105,7 +154,7 @@ END FUNCTION GetTotalInDOF_Quadrangle
INTERFACE
MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) &
- & RESULT(ans)
+ RESULT(ans)
CHARACTER(*), INTENT(IN) :: baseContinuity
!! Cointinuity (conformity) of basis functions
!! "H1", "HDiv", "HCurl", "DG"
@@ -125,9 +174,8 @@ END FUNCTION RefElemDomain_Quadrangle
! summary: This function returns the edge connectivity of Quadrangle
INTERFACE
- MODULE FUNCTION FacetConnectivity_Quadrangle( &
- & baseInterpol, &
- & baseContinuity) RESULT(ans)
+ MODULE FUNCTION FacetConnectivity_Quadrangle(baseInterpol, baseContinuity) &
+ RESULT(ans)
CHARACTER(*), INTENT(IN) :: baseInterpol
CHARACTER(*), INTENT(IN) :: baseContinuity
INTEGER(I4B) :: ans(2, 4)
@@ -141,11 +189,8 @@ END FUNCTION FacetConnectivity_Quadrangle
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE FUNCTION QuadratureNumber_Quadrangle( &
- & p, &
- & q, &
- & quadType1, &
- & quadType2) RESULT(ans)
+ MODULE PURE FUNCTION QuadratureNumber_Quadrangle(p, q, quadType1, &
+ quadType2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p, q
INTEGER(I4B), INTENT(IN) :: quadType1, quadType2
INTEGER(I4B) :: ans(2)
@@ -175,6 +220,22 @@ END FUNCTION LagrangeDegree_Quadrangle1
! date: 18 Aug 2022
! summary: Returns the degree of monomials for Lagrange polynomials
+INTERFACE LagrangeDegree_Quadrangle_
+ MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle1_(order, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeDegree_Quadrangle1_
+END INTERFACE LagrangeDegree_Quadrangle_
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Quadrangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Returns the degree of monomials for Lagrange polynomials
+
INTERFACE LagrangeDegree_Quadrangle
MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
@@ -183,6 +244,19 @@ MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans)
END FUNCTION LagrangeDegree_Quadrangle2
END INTERFACE LagrangeDegree_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeDegree_Quadrangle_
+ MODULE PURE SUBROUTINE LagrangeDegree_Quadrangle2_(p, q, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: p
+ INTEGER(I4B), INTENT(IN) :: q
+ INTEGER(I4B), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeDegree_Quadrangle2_
+END INTERFACE LagrangeDegree_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeDOF_Quadrangle
!----------------------------------------------------------------------------
@@ -278,8 +352,8 @@ END FUNCTION LagrangeInDOF_Quadrangle2
!- The node numbering is according to Gmsh convention.
INTERFACE EquidistancePoint_Quadrangle
- MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) &
- & RESULT(ans)
+ MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle1(order, xij) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
@@ -293,6 +367,28 @@ MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) &
END FUNCTION EquidistancePoint_Quadrangle1
END INTERFACE EquidistancePoint_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistancePoint_Quadrangle_
+ MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle1_(order, &
+ ans, nrow, ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates of interpolation points in $x_{iJ}$ format.
+ !! Number of rows in ans is equal to the 2
+ !! Number of columns in ans is equal to the number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! Nodal coordinates of quadrangle
+ !! number of rows = 2
+ !! number of cols = 4
+ END SUBROUTINE EquidistancePoint_Quadrangle1_
+END INTERFACE EquidistancePoint_Quadrangle_
+
!----------------------------------------------------------------------------
! EquidistancePoint_Quadrangle
!----------------------------------------------------------------------------
@@ -312,7 +408,7 @@ END FUNCTION EquidistancePoint_Quadrangle1
INTERFACE EquidistancePoint_Quadrangle
MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, &
- & xij) RESULT(ans)
+ xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order in x direction
INTEGER(I4B), INTENT(IN) :: q
@@ -328,6 +424,29 @@ MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, &
END FUNCTION EquidistancePoint_Quadrangle2
END INTERFACE EquidistancePoint_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE EquidistancePoint_Quadrangle_
+ MODULE RECURSIVE SUBROUTINE EquidistancePoint_Quadrangle2_(p, q, ans, &
+ nrow, ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order in y direction
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! Nodal coordinates of quadrangle
+ !! number of rows = 2 or 3
+ !! number of cols = 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates of interpolation points in $x_{iJ}$ format.
+ !! Number of rows in ans is equal to the 2
+ !! Number of columns in ans is equal to the number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE EquidistancePoint_Quadrangle2_
+END INTERFACE EquidistancePoint_Quadrangle_
+
!----------------------------------------------------------------------------
! EquidistanceInPoint_Quadrangle
!----------------------------------------------------------------------------
@@ -342,8 +461,8 @@ END FUNCTION EquidistancePoint_Quadrangle2
!- All points are inside the Quadrangle
INTERFACE EquidistanceInPoint_Quadrangle
- MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) &
- & RESULT(ans)
+ MODULE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
@@ -371,8 +490,8 @@ END FUNCTION EquidistanceInPoint_Quadrangle1
!- All points are inside the Quadrangle
INTERFACE EquidistanceInPoint_Quadrangle
- MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) &
- & RESULT(ans)
+ MODULE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order in x direction
INTEGER(I4B), INTENT(IN) :: q
@@ -418,12 +537,8 @@ END FUNCTION EquidistanceInPoint_Quadrangle2
! also follow the same convention. Please read Gmsh manual on this topic.
INTERFACE InterpolationPoint_Quadrangle
- MODULE FUNCTION InterpolationPoint_Quadrangle1( &
- & order, &
- & ipType, &
- & layout, &
- & xij, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION InterpolationPoint_Quadrangle1(order, ipType, layout, &
+ xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of element
INTEGER(I4B), INTENT(IN) :: ipType
@@ -460,6 +575,33 @@ MODULE FUNCTION InterpolationPoint_Quadrangle1( &
END FUNCTION InterpolationPoint_Quadrangle1
END INTERFACE InterpolationPoint_Quadrangle
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle_
+!----------------------------------------------------------------------------
+
+INTERFACE InterpolationPoint_Quadrangle_
+ MODULE SUBROUTINE InterpolationPoint_Quadrangle1_(order, ipType, ans, &
+ nrow, ncol, layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of element
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation point type
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ CHARACTER(*), INTENT(IN) :: layout
+ !! VEFC, INCREASING
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! four vertices of quadrangle in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE InterpolationPoint_Quadrangle1_
+END INTERFACE InterpolationPoint_Quadrangle_
+
!----------------------------------------------------------------------------
! InterpolationPoint_Quadrangle
!----------------------------------------------------------------------------
@@ -490,51 +632,16 @@ END FUNCTION InterpolationPoint_Quadrangle1
! also follow the same convention. Please read Gmsh manual on this topic.
INTERFACE InterpolationPoint_Quadrangle
- MODULE FUNCTION InterpolationPoint_Quadrangle2( &
- & p, q, ipType1, ipType2, layout, xij, alpha1, beta1, &
- & lambda1, alpha2, beta2, lambda2) RESULT(ans)
+ MODULE FUNCTION InterpolationPoint_Quadrangle2(p, q, ipType1, ipType2, &
+ layout, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order of element in x direction
INTEGER(I4B), INTENT(IN) :: q
!! order of element in y direction
INTEGER(I4B), INTENT(IN) :: ipType1
!! interpolation point type in x direction
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
INTEGER(I4B), INTENT(IN) :: ipType2
!! interpolation point type in y direction
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: layout
!! VEFC, INCREASING
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
@@ -556,6 +663,45 @@ MODULE FUNCTION InterpolationPoint_Quadrangle2( &
END FUNCTION InterpolationPoint_Quadrangle2
END INTERFACE InterpolationPoint_Quadrangle
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle_
+!----------------------------------------------------------------------------
+
+INTERFACE InterpolationPoint_Quadrangle_
+ MODULE SUBROUTINE InterpolationPoint_Quadrangle2_(p, q, ipType1, ipType2, &
+ ans, nrow, ncol, layout, xij, alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order of element in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order of element in y direction
+ INTEGER(I4B), INTENT(IN) :: ipType1
+ !! interpolation point type in x direction
+ INTEGER(I4B), INTENT(IN) :: ipType2
+ !! interpolation point type in y direction
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !!
+ CHARACTER(*), INTENT(IN) :: layout
+ !! VEFC, INCREASING
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! four vertices of quadrangle in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! Ultraspherical parameter
+ END SUBROUTINE InterpolationPoint_Quadrangle2_
+END INTERFACE InterpolationPoint_Quadrangle_
+
!----------------------------------------------------------------------------
! IJ2VEFC
!----------------------------------------------------------------------------
@@ -583,8 +729,8 @@ END SUBROUTINE IJ2VEFC_Quadrangle
! summary: Convert format from IJ to VEFC
INTERFACE
- MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise( &
- & xi, eta, temp, p, q, startNode)
+ MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_Clockwise(xi, eta, &
+ temp, p, q, startNode)
REAL(DFP), INTENT(IN) :: xi(:, :)
REAL(DFP), INTENT(IN) :: eta(:, :)
REAL(DFP), INTENT(OUT) :: temp(:, :)
@@ -603,8 +749,8 @@ END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise
! summary: Convert format from IJ to VEFC
INTERFACE
- MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise( &
- & xi, eta, temp, p, q, startNode)
+ MODULE PURE RECURSIVE SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, &
+ temp, p, q, startNode)
REAL(DFP), INTENT(IN) :: xi(:, :)
REAL(DFP), INTENT(IN) :: eta(:, :)
REAL(DFP), INTENT(OUT) :: temp(:, :)
@@ -631,13 +777,32 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle1(order, i, xij) RESULT(ans)
END FUNCTION LagrangeCoeff_Quadrangle1
END INTERFACE LagrangeCoeff_Quadrangle
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Quadrangle_
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Quadrangle_
+ MODULE SUBROUTINE LagrangeCoeff_Quadrangle1_(order, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Quadrangle1_
+END INTERFACE LagrangeCoeff_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Quadrangle
MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial, it should be SIZE(v,2)-1
INTEGER(I4B), INTENT(IN) :: i
@@ -651,6 +816,27 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle2(order, i, v, isVandermonde) &
END FUNCTION LagrangeCoeff_Quadrangle2
END INTERFACE LagrangeCoeff_Quadrangle
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Quadrangle_
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Quadrangle_
+ MODULE SUBROUTINE LagrangeCoeff_Quadrangle2_(order, i, v, isVandermonde, &
+ ans, tsize)
+ 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
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Quadrangle2_
+END INTERFACE LagrangeCoeff_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
@@ -670,18 +856,34 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle3(order, i, v, ipiv) RESULT(ans)
END FUNCTION LagrangeCoeff_Quadrangle3
END INTERFACE LagrangeCoeff_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Quadrangle_
+ MODULE SUBROUTINE LagrangeCoeff_Quadrangle3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Quadrangle3_
+END INTERFACE LagrangeCoeff_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Quadrangle
- MODULE FUNCTION LagrangeCoeff_Quadrangle4( &
- & order, &
- & xij, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeCoeff_Quadrangle4(order, xij, basisType, alpha, &
+ beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -704,23 +906,40 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle4( &
END FUNCTION LagrangeCoeff_Quadrangle4
END INTERFACE LagrangeCoeff_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Quadrangle_
+ MODULE SUBROUTINE LagrangeCoeff_Quadrangle4_(order, xij, basisType, &
+ alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! This parameter is needed when basisType is Ultraspherical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Quadrangle4_
+END INTERFACE LagrangeCoeff_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Quadrangle
- MODULE FUNCTION LagrangeCoeff_Quadrangle5( &
- & p, &
- & q, &
- & xij, &
- & basisType1, &
- & basisType2, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2) RESULT(ans)
+ MODULE FUNCTION LagrangeCoeff_Quadrangle5(p, q, xij, basisType1, &
+ basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order of polynomial in x direction
INTEGER(I4B), INTENT(IN) :: q
@@ -729,19 +948,11 @@ MODULE FUNCTION LagrangeCoeff_Quadrangle5( &
!! points in xij format, size(xij,2)
INTEGER(I4B), INTENT(IN) :: basisType1
!! basisType in x direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
INTEGER(I4B), INTENT(IN) :: basisType2
!! basisType in y direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
!! This parameter is needed when basisType is Jacobi
@@ -761,14 +972,55 @@ END FUNCTION LagrangeCoeff_Quadrangle5
END INTERFACE LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
-! DubinerPolynomial
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Dubiner (1991) polynomials on biunit domain
-!
-!# Introduction
+INTERFACE LagrangeCoeff_Quadrangle_
+ MODULE SUBROUTINE LagrangeCoeff_Quadrangle5_(p, q, xij, basisType1, &
+ basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2, &
+ ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order of polynomial in x direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order of polynomial in y direction
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2)
+ INTEGER(I4B), INTENT(IN) :: basisType1
+ !! basisType in x direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ INTEGER(I4B), INTENT(IN) :: basisType2
+ !! basisType in y direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! This parameter is needed when basisType is Ultraspherical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! This parameter is needed when basisType is Jacobi
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! This parameter is needed when basisType is Ultraspherical
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Quadrangle5_
+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
@@ -971,8 +1223,8 @@ MODULE PURE FUNCTION DubinerGradient_Quadrangle1(order, xij) RESULT(ans)
!! 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_I4B) * (order + 2_I4B) / 2_I4B, &
- & 2_I4B)
+ (order + 1_I4B) * (order + 2_I4B) / 2_I4B, &
+ 2_I4B)
!! shape functions
!! ans(:, j), jth shape functions at all points
!! ans(j, :), all shape functions at jth point
@@ -1050,19 +1302,8 @@ END SUBROUTINE DubinerGradient_Quadrangle1_
! polynomial on biunit quadrangle.
INTERFACE TensorProdBasis_Quadrangle
- MODULE FUNCTION TensorProdBasis_Quadrangle1( &
- & p, &
- & q, &
- & xij, &
- & basisType1, &
- & basisType2, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2) &
- & RESULT(ans)
+ MODULE FUNCTION TensorProdBasis_Quadrangle1(p, q, xij, basisType1, &
+ basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! highest order in x1 direction
INTEGER(I4B), INTENT(IN) :: q
@@ -1071,19 +1312,11 @@ MODULE FUNCTION TensorProdBasis_Quadrangle1( &
!! points of evaluation in xij format
INTEGER(I4B), INTENT(IN) :: basisType1
!! basis type in x1 direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
INTEGER(I4B), INTENT(IN) :: basisType2
!! basis type in x2 direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
!! alpha1 needed when basisType1 "Jacobi"
@@ -1106,6 +1339,48 @@ END FUNCTION TensorProdBasis_Quadrangle1
MODULE PROCEDURE TensorProdBasis_Quadrangle1
END INTERFACE OrthogonalBasis_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE TensorProdBasis_Quadrangle_
+ MODULE SUBROUTINE TensorProdBasis_Quadrangle1_(p, q, xij, ans, nrow, &
+ ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, &
+ beta2, lambda2)
+ 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
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (p + 1) * (q + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ INTEGER(I4B), INTENT(IN) :: basisType1
+ !! basis type in x1 direction
+ INTEGER(I4B), INTENT(IN) :: basisType2
+ !! basis type in x2 direction
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! alpha1 needed when basisType1 "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! beta1 is needed when basisType1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! lambda1 is needed when basisType1 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! alpha2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! beta2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! lambda2 is needed when basisType2 is "Ultraspherical"
+ END SUBROUTINE TensorProdBasis_Quadrangle1_
+END INTERFACE TensorProdBasis_Quadrangle_
+
+INTERFACE OrthogonalBasis_Quadrangle_
+ MODULE PROCEDURE TensorProdBasis_Quadrangle1_
+END INTERFACE OrthogonalBasis_Quadrangle_
+
!----------------------------------------------------------------------------
! TensorProdBasis_Quadrangle
!----------------------------------------------------------------------------
@@ -1121,20 +1396,8 @@ END FUNCTION TensorProdBasis_Quadrangle1
! outer product of x and y
INTERFACE TensorProdBasis_Quadrangle
- MODULE FUNCTION TensorProdBasis_Quadrangle2( &
- & p, &
- & q, &
- & x, &
- & y, &
- & basisType1, &
- & basisType2, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2) &
- & RESULT(ans)
+ MODULE FUNCTION TensorProdBasis_Quadrangle2(p, q, x, y, basisType1, &
+ basisType2, alpha1, beta1, lambda1, alpha2, beta2, lambda2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! highest order in x1 direction
INTEGER(I4B), INTENT(IN) :: q
@@ -1180,6 +1443,51 @@ END FUNCTION TensorProdBasis_Quadrangle2
MODULE PROCEDURE TensorProdBasis_Quadrangle2
END INTERFACE OrthogonalBasis_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE TensorProdBasis_Quadrangle_
+ MODULE SUBROUTINE TensorProdBasis_Quadrangle2_(p, q, x, y, ans, nrow, &
+ ncol, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2)
+ 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
+ REAL(DFP) :: ans(SIZE(x) * SIZE(y), (p + 1) * (q + 1))
+ !! nrow = SIZE(x) * SIZE(y)
+ !! ncol = (p + 1) * (q + 1)
+ !! Tensor basis
+ !! The number of rows corresponds to the
+ !! total number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ INTEGER(I4B), INTENT(IN) :: basisType1
+ !! Orthogonal polynomial family in x1 direction
+ INTEGER(I4B), INTENT(IN) :: basisType2
+ !! Orthogonal poly family in x2 direction
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! alpha1 needed when basisType1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! beta1 is needed when basisType1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! alpha2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! beta2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! lambda1 is needed when basisType1 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! lambda2 is needed when basisType2 is "Ultraspherical"
+ END SUBROUTINE TensorProdBasis_Quadrangle2_
+END INTERFACE TensorProdBasis_Quadrangle_
+
+INTERFACE OrthogonalBasis_Quadrangle_
+ MODULE PROCEDURE TensorProdBasis_Quadrangle2_
+END INTERFACE OrthogonalBasis_Quadrangle_
+
!----------------------------------------------------------------------------
! VertexBasis_Quadrangle
!----------------------------------------------------------------------------
@@ -1189,8 +1497,7 @@ END FUNCTION TensorProdBasis_Quadrangle2
! summary: Returns the vertex basis functions on biunit quadrangle
INTERFACE VertexBasis_Quadrangle
- MODULE PURE FUNCTION VertexBasis_Quadrangle1(x, y) &
- & RESULT(ans)
+ MODULE PURE FUNCTION VertexBasis_Quadrangle1(x, y) RESULT(ans)
REAL(DFP), INTENT(IN) :: x(:), y(:)
!! point of evaluation
REAL(DFP) :: ans(SIZE(x), 4)
@@ -1199,67 +1506,51 @@ END FUNCTION VertexBasis_Quadrangle1
END INTERFACE VertexBasis_Quadrangle
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Returns the vertex basis functions on biunit quadrangle
-
-INTERFACE VertexBasis_Quadrangle
- MODULE PURE FUNCTION VertexBasis_Quadrangle3(xij) &
- & RESULT(ans)
- REAL(DFP), INTENT(IN) :: xij(:, :)
+INTERFACE VertexBasis_Quadrangle_
+ MODULE PURE SUBROUTINE VertexBasis_Quadrangle1_(x, y, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: x(:), y(:)
!! point of evaluation
- REAL(DFP) :: ans(SIZE(xij, 2), 4)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), 4)
!! ans(:,v1) basis function of vertex v1 at all points
- END FUNCTION VertexBasis_Quadrangle3
-END INTERFACE VertexBasis_Quadrangle
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE VertexBasis_Quadrangle1_
+END INTERFACE VertexBasis_Quadrangle_
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle2
+! 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_Quadrangle2(L1, L2) RESULT(ans)
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
- !! L1 Lobatto polynomial evaluated at x coordinates
- !! L2 is Lobatto polynomial evaluated at y coordinates
- REAL(DFP) :: ans(SIZE(L1, 1), 4)
+INTERFACE VertexBasis_Quadrangle
+ MODULE PURE FUNCTION VertexBasis_Quadrangle2(xij) RESULT(ans)
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! point of evaluation
+ REAL(DFP) :: ans(SIZE(xij, 2), 4)
!! ans(:,v1) basis function of vertex v1 at all points
END FUNCTION VertexBasis_Quadrangle2
-END INTERFACE
+END INTERFACE VertexBasis_Quadrangle
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle2
+! VertexBasis_Quadrangle
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Returns the vertex basis functions on biunit quadrangle
-
-INTERFACE
- MODULE PURE FUNCTION VertexBasisGradient_Quadrangle2( &
- & L1, &
- & L2, &
- & dL1, &
- & dL2) RESULT(ans)
- REAL(DFP), INTENT(IN) :: L1(1:, 0:)
- !! L1 Lobatto polynomial evaluated at x coordinates
- REAL(DFP), INTENT(IN) :: L2(1:, 0:)
- !! L2 is Lobatto polynomial evaluated at y coordinates
- REAL(DFP), INTENT(IN) :: dL1(1:, 0:)
- !! L1 Lobatto polynomial evaluated at x coordinates
- REAL(DFP), INTENT(IN) :: dL2(1:, 0:)
- !! L2 is Lobatto polynomial evaluated at y coordinates
- REAL(DFP) :: ans(SIZE(L1, 1), 4, 2)
- !! Gradient of vertex basis
- END FUNCTION VertexBasisGradient_Quadrangle2
-END INTERFACE
+INTERFACE VertexBasis_Quadrangle_
+ MODULE PURE SUBROUTINE VertexBasis_Quadrangle2_(xij, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), 4)
+ !! ans(:,v1) basis function of vertex v1 at all points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE VertexBasis_Quadrangle2_
+END INTERFACE VertexBasis_Quadrangle_
!----------------------------------------------------------------------------
! VerticalEdgeBasis_Quadrangle
@@ -1279,7 +1570,7 @@ END FUNCTION VertexBasisGradient_Quadrangle2
INTERFACE
MODULE PURE FUNCTION VerticalEdgeBasis_Quadrangle(qe1, qe2, x, y) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: qe1
!! order on left vertical edge (e1), it should be greater than 1
!! It should be greater than 2
@@ -1298,41 +1589,21 @@ END FUNCTION 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), it should be greater than 1
- INTEGER(I4B), INTENT(IN) :: qe2
- !! order on right vertical edge(e2), it should be greater than 1
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
- !! Lobatto polynomials in x and y direction.
- REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2)
- END FUNCTION VerticalEdgeBasis_Quadrangle2
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-INTERFACE
- MODULE PURE FUNCTION VerticalEdgeBasisGradient_Quadrangle2( &
- & qe1, &
- & qe2, &
- & L1, &
- & L2, &
- & dL1, &
- & dL2) &
- & RESULT(ans)
+ MODULE PURE SUBROUTINE VerticalEdgeBasis_Quadrangle_(qe1, qe2, x, y, &
+ ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: qe1
!! order on left vertical edge (e1), it should be greater than 1
+ !! It should be greater than 2
INTEGER(I4B), INTENT(IN) :: qe2
!! order on right vertical edge(e2), it should be greater than 1
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
- !! Lobatto polynomials in x and y direction.
- REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
- !! Lobatto polynomials in x and y direction.
- REAL(DFP) :: ans(SIZE(L1, 1), qe1 + qe2 - 2, 2)
- END FUNCTION VerticalEdgeBasisGradient_Quadrangle2
+ !! It should be greater than 2
+ REAL(DFP), INTENT(IN) :: x(:), y(:)
+ !! point of evaluation
+ !! these points should be between [-1, 1].
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(x), qe1 + qe2 - 2)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE VerticalEdgeBasis_Quadrangle_
END INTERFACE
!----------------------------------------------------------------------------
@@ -1350,8 +1621,7 @@ END FUNCTION VerticalEdgeBasisGradient_Quadrangle2
! pe3 and pe4 should be greater than or equal to 2
INTERFACE
- MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) &
- & RESULT(ans)
+ MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: pe3
!! order on bottom vertical edge (e3), it should be greater than 1
INTEGER(I4B), INTENT(IN) :: pe4
@@ -1367,39 +1637,18 @@ END FUNCTION HorizontalEdgeBasis_Quadrangle
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle2(pe3, pe4, L1, L2) &
- & RESULT(ans)
+ MODULE PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, &
+ ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: pe3
!! order on bottom vertical edge (e3), it should be greater than 1
INTEGER(I4B), INTENT(IN) :: pe4
!! order on top vertical edge(e4), it should be greater than 1
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ REAL(DFP), INTENT(IN) :: x(:), y(:)
!! point of evaluation
- REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2)
- END FUNCTION HorizontalEdgeBasis_Quadrangle2
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-INTERFACE
- MODULE PURE FUNCTION HorizontalEdgeBasisGradient_Quadrangle2( &
- &pe3, &
- & pe4, &
- & L1, &
- & L2, &
- & dL1, &
- & dL2) &
- & RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: pe3
- !! order on bottom vertical edge (e3), it should be greater than 1
- INTEGER(I4B), INTENT(IN) :: pe4
- !! order on top vertical edge(e4), it should be greater than 1
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
- REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
- REAL(DFP) :: ans(SIZE(L1, 1), pe3 + pe4 - 2, 2)
- END FUNCTION HorizontalEdgeBasisGradient_Quadrangle2
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), pe3 + pe4 - 2)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HorizontalEdgeBasis_Quadrangle_
END INTERFACE
!----------------------------------------------------------------------------
@@ -1427,41 +1676,22 @@ END FUNCTION CellBasis_Quadrangle
END INTERFACE
!----------------------------------------------------------------------------
-! CellBasis_Quadrangle
+!
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans)
+ MODULE PURE SUBROUTINE CellBasis_Quadrangle_(pb, qb, x, y, ans, nrow, &
+ ncol)
INTEGER(I4B), INTENT(IN) :: pb
!! order on bottom vertical edge (e3), it should be greater than 1
INTEGER(I4B), INTENT(IN) :: qb
!! order on top vertical edge(e4), it should be greater than 1
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ REAL(DFP), INTENT(IN) :: x(:), y(:)
!! point of evaluation
- REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1))
- END FUNCTION CellBasis_Quadrangle2
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! CellBasisGradient_Quadrangle
-!----------------------------------------------------------------------------
-
-INTERFACE
- MODULE PURE FUNCTION CellBasisGradient_Quadrangle2( &
- & pb, &
- & qb, &
- & L1, &
- & L2, &
- & dL1, &
- & dL2) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: pb
- !! order on bottom vertical edge (e3), it should be greater than 1
- INTEGER(I4B), INTENT(IN) :: qb
- !! order on top vertical edge(e4), it should be greater than 1
- REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
- REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
- REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1), 2)
- END FUNCTION CellBasisGradient_Quadrangle2
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), (pb - 1) * (qb - 1))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE CellBasis_Quadrangle_
END INTERFACE
!----------------------------------------------------------------------------
@@ -1486,7 +1716,7 @@ END FUNCTION CellBasisGradient_Quadrangle2
INTERFACE HeirarchicalBasis_Quadrangle
MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, &
- & qe1, qe2, xij) RESULT(ans)
+ qe1, qe2, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: pb
!! order of interpolation inside the quadrangle in x1 direction
INTEGER(I4B), INTENT(IN) :: qb
@@ -1507,6 +1737,34 @@ MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle1(pb, qb, pe3, pe4, &
END FUNCTION HeirarchicalBasis_Quadrangle1
END INTERFACE HeirarchicalBasis_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Quadrangle_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle1_(pb, qb, pe3, pe4, &
+ qe1, qe2, xij, ans, nrow, ncol)
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(xij, 2), &
+ !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Quadrangle1_
+END INTERFACE HeirarchicalBasis_Quadrangle_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Quadrangle
!----------------------------------------------------------------------------
@@ -1534,62 +1792,196 @@ END FUNCTION HeirarchicalBasis_Quadrangle2
END INTERFACE HeirarchicalBasis_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeEvalAll_Quadrangle
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-04
-! summary: Evaluate all Lagrange polynomial of order n at single points
+INTERFACE HeirarchicalBasis_Quadrangle_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle2_(p, q, xij, ans, &
+ nrow, ncol)
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (p + 1) * (q + 1))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Quadrangle2_
+END INTERFACE HeirarchicalBasis_Quadrangle_
-INTERFACE LagrangeEvalAll_Quadrangle
- MODULE FUNCTION LagrangeEvalAll_Quadrangle1( &
- & order, &
- & x, &
- & xij, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of Lagrange polynomials
- REAL(DFP), INTENT(IN) :: x(2)
- !! point of evaluation
- !! x(1) is x coord
- !! x(2) is y coord
- REAL(DFP), INTENT(INOUT) :: xij(:, :)
- !! Interpolation points
- !! The number of rows in xij can be 2 or 3
- !! The number of columns in xij should be equal to total
- !! degree of freedom
- REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
- !! coefficient of Lagrange polynomials
- LOGICAL(LGT), OPTIONAL :: firstCall
- !! If firstCall is true, then coeff will be computed and returned
- !! by this routine.
- !! If firstCall is False, then coeff should be given, which will be
- !! used.
- !! Default value of firstCall is True
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Monomials *Default
- !! Legendre
- !! Lobatto
- !! Chebyshev
- !! Jacobi
- !! Ultraspherical
- !! Heirarchical
- REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
- !! Jacobi parameter
- REAL(DFP), OPTIONAL, INTENT(IN) :: beta
- !! Jacobi parameter
- REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
- !! Ultraspherical parameter
- REAL(DFP) :: ans(SIZE(xij, 2))
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Quadrangle
+ MODULE PURE FUNCTION HeirarchicalBasis_Quadrangle3(pb, qb, pe3, pe4, &
+ qe1, qe2, xij, pe3Orient, pe4Orient, qe1Orient, qe2Orient, &
+ faceOrient) 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
+ INTEGER(I4B), INTENT(IN) :: pe3Orient
+ !! orientation of edge 1
+ INTEGER(I4B), INTENT(IN) :: pe4Orient
+ !! orientation of edge 2
+ INTEGER(I4B), INTENT(IN) :: qe1Orient
+ !! orientation of edge 3
+ INTEGER(I4B), INTENT(IN) :: qe2Orient
+ !! orientation of edge 4
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:)
+ !! orientation of face
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! nrow = SIZE(xij, 2)
+ !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1
+ END FUNCTION HeirarchicalBasis_Quadrangle3
+END INTERFACE HeirarchicalBasis_Quadrangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Quadrangle_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Quadrangle3_(pb, qb, pe3, pe4, &
+ qe1, qe2, xij, pe3Orient, pe4Orient, qe1Orient, qe2Orient, &
+ faceOrient, ans, nrow, ncol)
+ 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
+ INTEGER(I4B), INTENT(IN) :: pe3Orient
+ !! orientation of edge 1
+ INTEGER(I4B), INTENT(IN) :: pe4Orient
+ !! orientation of edge 2
+ INTEGER(I4B), INTENT(IN) :: qe1Orient
+ !! orientation of edge 3
+ INTEGER(I4B), INTENT(IN) :: qe2Orient
+ !! orientation of edge 4
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:)
+ !! orientation of face
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(xij, 2), &
+ !! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Quadrangle3_
+END INTERFACE HeirarchicalBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-04
+! summary: Evaluate all Lagrange polynomial of order n at single points
+
+INTERFACE LagrangeEvalAll_Quadrangle
+ MODULE FUNCTION LagrangeEvalAll_Quadrangle1(order, x, xij, coeff, &
+ firstCall, basisType, alpha, beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(2)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ !! The number of rows in xij can be 2 or 3
+ !! The number of columns in xij should be equal to total
+ !! degree of freedom
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be computed and returned
+ !! by this routine.
+ !! If firstCall is False, then coeff should be given, which will be
+ !! used.
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP) :: ans(SIZE(xij, 2))
!! Value of n+1 Lagrange polynomials at point x
END FUNCTION LagrangeEvalAll_Quadrangle1
END INTERFACE LagrangeEvalAll_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Quadrangle_
+ MODULE SUBROUTINE LagrangeEvalAll_Quadrangle1_(order, x, xij, ans, tsize, &
+ coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(2)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ !! The number of rows in xij can be 2 or 3
+ !! The number of columns in xij should be equal to total
+ !! degree of freedom
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Total size written in ans
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be computed and returned
+ !! by this routine.
+ !! If firstCall is False, then coeff should be given, which will be
+ !! used.
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Legendre
+ !! Lobatto
+ !! Chebyshev
+ !! Jacobi
+ !! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Quadrangle1_
+END INTERFACE LagrangeEvalAll_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Quadrangle
!----------------------------------------------------------------------------
@@ -1599,17 +1991,8 @@ END FUNCTION LagrangeEvalAll_Quadrangle1
! summary: Evaluate all Lagrange polynomials of order n at several points
INTERFACE LagrangeEvalAll_Quadrangle
- MODULE FUNCTION LagrangeEvalAll_Quadrangle2( &
- & order, &
- & x, &
- & xij, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda &
- & ) RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll_Quadrangle2(order, x, xij, coeff, &
+ firstCall, basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(:, :)
@@ -1639,6 +2022,46 @@ MODULE FUNCTION LagrangeEvalAll_Quadrangle2( &
END FUNCTION LagrangeEvalAll_Quadrangle2
END INTERFACE LagrangeEvalAll_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Quadrangle_
+ MODULE SUBROUTINE LagrangeEvalAll_Quadrangle2_(order, x, xij, ans, &
+ nrow, ncol, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x, 2), SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Jacobi=Dubiner
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Quadrangle2_
+END INTERFACE LagrangeEvalAll_Quadrangle_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Quadrangle
!----------------------------------------------------------------------------
@@ -1648,38 +2071,21 @@ END FUNCTION LagrangeEvalAll_Quadrangle2
! summary: Returns quadrature points on reference quadrangle
INTERFACE QuadraturePoint_Quadrangle
- MODULE FUNCTION QuadraturePoint_Quadrangle1( &
- & order, &
- & quadType, &
- & refQuadrangle, &
- & xij, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Quadrangle1(order, quadType, &
+ refQuadrangle, xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of integrand in x and y direction
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature point type
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadauLeft
+ !! GaussLegendreRadauRight ! GaussChebyshev1 ! GaussChebyshev1Lobatto
+ !! GaussChebyshev1RadauLeft ! GaussChebyshev1RadauRight
+ !! GaussUltraspherical ! GaussUltrasphericalLobatto
+ !! GaussUltrasphericalRadauLeft ! GaussUltrasphericalRadauRight
+ !! GaussJacobi ! GaussJacobiLobatto
+ !! GaussJacobiRadauLeft ! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refQuadrangle
- !! Reference quadrangle
- !! UNIT
- !! BIUNIT
+ !! Reference quadrangle ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! four vertices of quadrangle in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
@@ -1698,36 +2104,24 @@ END FUNCTION QuadraturePoint_Quadrangle1
!----------------------------------------------------------------------------
INTERFACE QuadraturePoint_Quadrangle
- MODULE FUNCTION QuadraturePoint_Quadrangle2( &
- & p, q, quadType1, quadType2, refQuadrangle, xij, alpha1, beta1, &
- & lambda1, alpha2, beta2, lambda2) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Quadrangle2(p, q, quadType1, quadType2, &
+ refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, lambda2) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! order of integrand in x direction
INTEGER(I4B), INTENT(IN) :: q
!! order of integrand in y direction
INTEGER(I4B), INTENT(IN) :: quadType1, quadType2
!! quadrature point type in x direction
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1
+ !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft
+ !! GaussChebyshev1RadauRight ! GaussUltraspherical
+ !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft
+ !! GaussUltrasphericalRadauRight ! GaussJacobi
+ !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refQuadrangle
- !! Reference quadrangle
- !! UNIT
- !! BIUNIT
+ !! Reference quadrangle ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! four vertices of quadrangle in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
@@ -1757,31 +2151,19 @@ END FUNCTION QuadraturePoint_Quadrangle2
INTERFACE QuadraturePoint_Quadrangle
MODULE FUNCTION QuadraturePoint_Quadrangle3(nips, quadType, &
- & refQuadrangle, xij, alpha, beta, lambda) RESULT(ans)
+ refQuadrangle, xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: nips(1)
!! number of integration points in x and y direction
INTEGER(I4B), INTENT(IN) :: quadType
- !! interpolation point type
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
+ !! interpolation point type ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1
+ !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft
+ !! GaussChebyshev1RadauRight ! GaussUltraspherical
+ !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft
+ !! GaussUltrasphericalRadauRight ! GaussJacobi
+ !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refQuadrangle
- !! Reference quadrangle
- !! UNIT
- !! BIUNIT
+ !! Reference quadrangle ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! four vertices of quadrangle in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
@@ -1800,37 +2182,24 @@ END FUNCTION QuadraturePoint_Quadrangle3
!----------------------------------------------------------------------------
INTERFACE QuadraturePoint_Quadrangle
- MODULE FUNCTION QuadraturePoint_Quadrangle4( &
- & nipsx, nipsy, quadType1, quadType2, &
- & refQuadrangle, xij, alpha1, beta1, &
- & lambda1, alpha2, beta2, lambda2) RESULT(ans)
+ MODULE FUNCTION QuadraturePoint_Quadrangle4(nipsx, nipsy, quadType1, &
+ quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: nipsx(1)
!! order of integrand in x direction
INTEGER(I4B), INTENT(IN) :: nipsy(1)
!! order of integrand in y direction
INTEGER(I4B), INTENT(IN) :: quadType1, quadType2
!! interpolation point type in x direction
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev1
- !! GaussChebyshev1Lobatto
- !! GaussChebyshev1RadauLeft
- !! GaussChebyshev1RadauRight
- !! GaussUltraspherical
- !! GaussUltrasphericalLobatto
- !! GaussUltrasphericalRadauLeft
- !! GaussUltrasphericalRadauRight
- !! GaussJacobi
- !! GaussJacobiLobatto
- !! GaussJacobiRadauLeft
- !! GaussJacobiRadauRight
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1
+ !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft
+ !! GaussChebyshev1RadauRight ! GaussUltraspherical
+ !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft
+ !! GaussUltrasphericalRadauRight ! GaussJacobi
+ !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight
CHARACTER(*), INTENT(IN) :: refQuadrangle
- !! Reference quadrangle
- !! UNIT
- !! BIUNIT
+ !! Reference quadrangle ! UNIT ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! four vertices of quadrangle in xij format
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
@@ -1850,6 +2219,50 @@ MODULE FUNCTION QuadraturePoint_Quadrangle4( &
END FUNCTION QuadraturePoint_Quadrangle4
END INTERFACE QuadraturePoint_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Quadrangle_
+ MODULE SUBROUTINE QuadraturePoint_Quadrangle1_(nipsx, nipsy, quadType1, &
+ quadType2, refQuadrangle, xij, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nipsx(1)
+ !! order of integrand in x direction
+ INTEGER(I4B), INTENT(IN) :: nipsy(1)
+ !! order of integrand in y direction
+ INTEGER(I4B), INTENT(IN) :: quadType1, quadType2
+ !! interpolation point type in x direction
+ !! Equidistance ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev1
+ !! GaussChebyshev1Lobatto ! GaussChebyshev1RadauLeft
+ !! GaussChebyshev1RadauRight ! GaussUltraspherical
+ !! GaussUltrasphericalLobatto ! GaussUltrasphericalRadauLeft
+ !! GaussUltrasphericalRadauRight ! GaussJacobi
+ !! GaussJacobiLobatto ! GaussJacobiRadauLeft ! GaussJacobiRadauRight
+ CHARACTER(*), INTENT(IN) :: refQuadrangle
+ !! Reference quadrangle ! UNIT ! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! four vertices of quadrangle in xij format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! Ultraspherical parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! interpolation points in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ END SUBROUTINE QuadraturePoint_Quadrangle1_
+END INTERFACE QuadraturePoint_Quadrangle_
+
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Quadrangle
!----------------------------------------------------------------------------
@@ -1859,14 +2272,8 @@ END FUNCTION QuadraturePoint_Quadrangle4
! summary: Evaluate Lagrange polynomials of n at several points
INTERFACE LagrangeGradientEvalAll_Quadrangle
- MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( &
- & order, &
- & x, &
- & xij, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1(order, x, xij, coeff, &
+ firstCall, basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(:, :)
@@ -1904,6 +2311,51 @@ MODULE FUNCTION LagrangeGradientEvalAll_Quadrangle1( &
END FUNCTION LagrangeGradientEvalAll_Quadrangle1
END INTERFACE LagrangeGradientEvalAll_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeGradientEvalAll_Quadrangle_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_(order, x, xij, &
+ ans, dim1, dim2, dim3, coeff, firstCall, basisType, alpha, beta, &
+ lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! point of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ !! xij should be present when firstCall is true.
+ !! It is used for computing the coeff
+ !! If coeff is absent then xij should be present
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1 = SIZE(x, 2)
+ !! dim2 = SIZE(xij, 2)
+ !! dim3 = 2
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !!
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Quadrangle1_
+END INTERFACE LagrangeGradientEvalAll_Quadrangle_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Quadrangle
!----------------------------------------------------------------------------
@@ -1924,14 +2376,8 @@ END FUNCTION LagrangeGradientEvalAll_Quadrangle1
! Ultraspherical polynomials with lambda = 3/2.
INTERFACE HeirarchicalBasisGradient_Quadrangle
- MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1( &
- & pb, &
- & qb, &
- & pe3, &
- & pe4, &
- & qe1, &
- & qe2, &
- & xij) RESULT(ans)
+ MODULE FUNCTION HeirarchicalBasisGradient_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
@@ -1951,6 +2397,35 @@ MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle1( &
END FUNCTION HeirarchicalBasisGradient_Quadrangle1
END INTERFACE HeirarchicalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Quadrangle_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle1_(pb, qb, pe3, &
+ pe4, qe1, qe2, xij, ans, dim1, dim2, dim3)
+ 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), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1
+ !! dim3 = 2
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle1_
+END INTERFACE HeirarchicalBasisGradient_Quadrangle_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Quadrangle
!----------------------------------------------------------------------------
@@ -1960,10 +2435,7 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle1
! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle
INTERFACE HeirarchicalBasisGradient_Quadrangle
- MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2( &
- & p, &
- & q, &
- & xij) RESULT(ans)
+ MODULE FUNCTION HeirarchicalBasisGradient_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
@@ -1974,6 +2446,107 @@ MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle2( &
END FUNCTION HeirarchicalBasisGradient_Quadrangle2
END INTERFACE HeirarchicalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Quadrangle_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_(p, q, xij, &
+ ans, dim1, dim2, dim3)
+ 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), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = (p+1)*(q+1)
+ !! dim3 = 2
+ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle2_
+END INTERFACE HeirarchicalBasisGradient_Quadrangle_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-06
+! summary: Basis gradient
+
+INTERFACE HeirarchicalBasisGradient_Quadrangle
+ MODULE FUNCTION HeirarchicalBasisGradient_Quadrangle3(pb, qb, pe3, pe4, &
+ qe1, qe2, xij, qe1Orient, qe2Orient, pe3Orient, pe4Orient, faceOrient) &
+ 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
+ INTEGER(I4B), INTENT(IN) :: qe1Orient
+ !! left vertical edge orientation
+ INTEGER(I4B), INTENT(IN) :: qe2Orient
+ !! right vertical edge orientation
+ INTEGER(I4B), INTENT(IN) :: pe3Orient
+ !! orientation of bottom horizontal edge
+ INTEGER(I4B), INTENT(IN) :: pe4Orient
+ !! orientation of top horizontal edge
+ INTEGER(I4B), INTENT(IN) :: faceOrient(3)
+ !! orientation of faces
+ REAL(DFP), ALLOCATABLE :: ans(:, :, :)
+ END FUNCTION HeirarchicalBasisGradient_Quadrangle3
+END INTERFACE HeirarchicalBasisGradient_Quadrangle
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Quadrangle_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Quadrangle3_(pb, qb, pe3, pe4, &
+ qe1, qe2, xij, qe1Orient, qe2Orient, pe3Orient, pe4Orient, faceOrient, &
+ ans, dim1, dim2, dim3)
+ 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
+ INTEGER(I4B), INTENT(IN) :: qe1Orient
+ !! left vertical edge orientation
+ INTEGER(I4B), INTENT(IN) :: qe2Orient
+ !! right vertical edge orientation
+ INTEGER(I4B), INTENT(IN) :: pe3Orient
+ !! orientation of bottom horizontal edge
+ INTEGER(I4B), INTENT(IN) :: pe4Orient
+ !! orientation of top horizontal edge
+ INTEGER(I4B), INTENT(IN) :: faceOrient(3)
+ !! orientation of faces
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1
+ !! dim3 = 2
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE HeirarchicalBasisGradient_Quadrangle3_
+END INTERFACE HeirarchicalBasisGradient_Quadrangle_
+
!----------------------------------------------------------------------------
! TensorProdBasisGradient_Quadrangle
!----------------------------------------------------------------------------
@@ -1983,19 +2556,9 @@ END FUNCTION HeirarchicalBasisGradient_Quadrangle2
! summary: Evaluate all tensor product orthogoanl polynomial on quadrangle
INTERFACE TensorProdBasisGradient_Quadrangle
- MODULE FUNCTION TensorProdBasisGradient_Quadrangle1( &
- & p, &
- & q, &
- & xij, &
- & basisType1, &
- & basisType2, &
- & alpha1, &
- & beta1, &
- & lambda1, &
- & alpha2, &
- & beta2, &
- & lambda2) &
- & RESULT(ans)
+ MODULE FUNCTION TensorProdBasisGradient_Quadrangle1(p, q, xij, &
+ basisType1, basisType2, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p
!! highest order in x1 direction
INTEGER(I4B), INTENT(IN) :: q
@@ -2004,19 +2567,11 @@ MODULE FUNCTION TensorProdBasisGradient_Quadrangle1( &
!! points of evaluation in xij format
INTEGER(I4B), INTENT(IN) :: basisType1
!! basis type in x1 direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
INTEGER(I4B), INTENT(IN) :: basisType2
!! basis type in x2 direction
- !! Monomials
- !! Jacobi
- !! Legendre
- !! Chebyshev
- !! Ultraspherical
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
!! Heirarchical
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
!! alpha1 needed when basisType1 "Jacobi"
@@ -2039,4 +2594,51 @@ END FUNCTION TensorProdBasisGradient_Quadrangle1
MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1
END INTERFACE OrthogonalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE TensorProdBasisGradient_Quadrangle_
+ MODULE SUBROUTINE TensorProdBasisGradient_Quadrangle1_(p, q, xij, ans, &
+ dim1, dim2, dim3, basisType1, basisType2, alpha1, beta1, lambda1, alpha2, &
+ beta2, lambda2)
+ 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
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = (p + 1) * (q + 1)
+ !! dim3 = 2
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dimension of data written in ans
+ INTEGER(I4B), INTENT(IN) :: basisType1
+ !! basis type in x1 direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ INTEGER(I4B), INTENT(IN) :: basisType2
+ !! basis type in x2 direction
+ !! Monomials ! Jacobi ! Legendre ! Chebyshev ! Ultraspherical
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1
+ !! alpha1 needed when basisType1 "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
+ !! beta1 is needed when basisType1 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
+ !! lambda1 is needed when basisType1 is "Ultraspherical"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
+ !! alpha2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
+ !! beta2 needed when basisType2 is "Jacobi"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
+ !! lambda2 is needed when basisType2 is "Ultraspherical"
+ END SUBROUTINE TensorProdBasisGradient_Quadrangle1_
+END INTERFACE TensorProdBasisGradient_Quadrangle_
+
+INTERFACE OrthogonalBasisGradient_Quadrangle_
+ MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_
+END INTERFACE OrthogonalBasisGradient_Quadrangle_
+
END MODULE QuadrangleInterpolationUtility
diff --git a/src/modules/Polynomial/src/RecursiveNodesUtility.F90 b/src/modules/Polynomial/src/RecursiveNodesUtility.F90
index e45d75fde..f4a96f155 100644
--- a/src/modules/Polynomial/src/RecursiveNodesUtility.F90
+++ b/src/modules/Polynomial/src/RecursiveNodesUtility.F90
@@ -16,13 +16,20 @@
!
MODULE RecursiveNodesUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: RecursiveNode1D
PUBLIC :: RecursiveNode2D
PUBLIC :: RecursiveNode3D
+PUBLIC :: RecursiveNode1D_
+PUBLIC :: RecursiveNode2D_
+PUBLIC :: RecursiveNode3D_
+
!----------------------------------------------------------------------------
! RecursiveNode1D
!----------------------------------------------------------------------------
@@ -32,36 +39,73 @@ MODULE RecursiveNodesUtility
! summary: RecursiveNodes in 1D
INTERFACE
- MODULE FUNCTION RecursiveNode1D(order, ipType, &
- & domain, alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION RecursiveNode1D(order, ipType, domain, alpha, beta, &
+ lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
- !! order >= 0
+ !! order >= 0
INTEGER(I4B), INTENT(IN) :: ipType
- !! interpolation point type
- !! Equidistance
- !! LobattoGaussJacobi
- !! LobattoGaussChebyshev
- !! LobattoGaussGegenbauer
- !! GaussJacobi
- !! GaussChebyshev
- !! GaussGegenbauer
+ !! 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
+ !! barycentric coordinates, in xiJ format
+ !! size(ans,1) = 2 corresponding to b0 and b1
+ !! size(ans,2) total number of points
CHARACTER(*), OPTIONAL, INTENT(IN) :: domain
- !! unit (0,1)
- !! biunit (-1, 1)
- !! equilateral
+ !! unit (0,1)
+ !! biunit (-1, 1)
+ !! equilateral
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
- !! Ultraspherical polynomial parameter
+ !! Ultraspherical polynomial parameter
END FUNCTION RecursiveNode1D
END INTERFACE
+!----------------------------------------------------------------------------
+! RecursiveNode1D_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE RecursiveNode1D_(order, ipType, domain, alpha, beta, &
+ lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order >= 0
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation point type
+ !! Equidistance
+ !! LobattoGaussJacobi
+ !! LobattoGaussChebyshev
+ !! LobattoGaussGegenbauer
+ !! GaussJacobi
+ !! GaussChebyshev
+ !! GaussGegenbauer
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! barycentric coordinates, in xiJ format
+ !! size(ans,1) = 2 corresponding to b0 and b1
+ !! size(ans,2) total number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns of ans
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: domain
+ !! unit (0,1)
+ !! biunit (-1, 1)
+ !! equilateral
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE RecursiveNode1D_
+END INTERFACE
+
!----------------------------------------------------------------------------
! RecursiveNode2D
!----------------------------------------------------------------------------
@@ -71,43 +115,73 @@ END FUNCTION RecursiveNode1D
! summary: RecursiveNodes in 2D
INTERFACE
- MODULE FUNCTION RecursiveNode2D( &
- & order, &
- & ipType, &
- & domain, &
- & alpha, &
- & beta, &
- & lambda &
- & ) &
- & RESULT(ans)
+ MODULE FUNCTION RecursiveNode2D(order, ipType, domain, alpha, beta, &
+ lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
- !! order >= 0
+ !! order >= 0
INTEGER(I4B), INTENT(IN) :: ipType
- !! interpolation point type
- !! Equidistance
- !! LobattoGaussJacobi
- !! LobattoGaussChebyshev
- !! LobattoGaussGegenbauer
- !! GaussJacobi
- !! GaussChebyshev
- !! GaussGegenbauer
+ !! 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
+ !! barycentric coordinates, in xiJ format
+ !! size(ans,1) = 3 corresponding to b0, b1, b2
+ !! size(ans,2) total number of points
CHARACTER(*), OPTIONAL, INTENT(IN) :: domain
- !! unit
- !! Biunit
- !! Equilateral
+ !! unit
+ !! Biunit
+ !! Equilateral
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
- !! Ultraspherical polynomial parameter
+ !! Ultraspherical polynomial parameter
END FUNCTION RecursiveNode2D
END INTERFACE
+!----------------------------------------------------------------------------
+! RecursiveNode2D_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE RecursiveNode2D_(order, ipType, ans, nrow, ncol, &
+ domain, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order >= 0
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation point type
+ !! Equidistance
+ !! LobattoGaussJacobi
+ !! LobattoGaussChebyshev
+ !! LobattoGaussGegenbauer
+ !! GaussJacobi
+ !! GaussChebyshev
+ !! GaussGegenbauer
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! barycentric coordinates, in xiJ format
+ !! size(ans,1) = 3 corresponding to b0, b1, b2
+ !! size(ans,2) total number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns of ans
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: domain
+ !! unit
+ !! Biunit
+ !! Equilateral
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE RecursiveNode2D_
+END INTERFACE
+
!----------------------------------------------------------------------------
! RecursiveNode3D
!----------------------------------------------------------------------------
@@ -117,42 +191,77 @@ END FUNCTION RecursiveNode2D
! summary: Recursive nodes in 3D
INTERFACE
- MODULE FUNCTION RecursiveNode3D( &
- & order, &
- & ipType, &
- & domain, &
- & alpha, &
- & beta, &
- & lambda &
- & ) RESULT(ans)
+ MODULE FUNCTION RecursiveNode3D(order, ipType, domain, alpha, beta, &
+ lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
- !! order >= 0
+ !! order >= 0
INTEGER(I4B), INTENT(IN) :: ipType
- !! interpolation point type
- !! Equidistance
- !! LobattoGaussJacobi
- !! LobattoGaussChebyshev
- !! LobattoGaussGegenbauer
- !! GaussJacobi
- !! GaussChebyshev
- !! GaussGegenbauer
+ !! 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
+ !! barycentric coordinates, in xiJ format
+ !! size(ans,1) = 4 corresponding to b0, b1, b2, b3
+ !! size(ans,2) total number of points
CHARACTER(*), OPTIONAL, INTENT(IN) :: domain
- !! unit
- !! Biunit
- !! Equilateral
+ !! unit
+ !! Biunit
+ !! Equilateral
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
- !! Ultraspherical polynomial parameter
+ !! Ultraspherical polynomial parameter
END FUNCTION RecursiveNode3D
END INTERFACE
+!----------------------------------------------------------------------------
+! RecursiveNode3D_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-26
+! summary: Recursive node 3D without allocation
+
+INTERFACE
+ MODULE SUBROUTINE RecursiveNode3D_(order, ipType, ans, nrow, ncol, &
+ domain, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order >= 0
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation point type
+ !! Equidistance
+ !! LobattoGaussJacobi
+ !! LobattoGaussChebyshev
+ !! LobattoGaussGegenbauer
+ !! GaussJacobi
+ !! GaussChebyshev
+ !! GaussGegenbauer
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! barycentric coordinates, in xiJ format
+ !! size(ans,1) = 4 corresponding to b0, b1, b2, b3
+ !! size(ans,2) total number of points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns of ans
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: domain
+ !! unit
+ !! Biunit
+ !! Equilateral
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE RecursiveNode3D_
+END INTERFACE
+
!----------------------------------------------------------------------------
! ToUnit
!----------------------------------------------------------------------------
@@ -165,6 +274,19 @@ MODULE PURE FUNCTION ToUnit(x, domain) RESULT(ans)
END FUNCTION ToUnit
END INTERFACE
+!----------------------------------------------------------------------------
+! ToUnit
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE ToUnit_(x, domain, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ CHARACTER(*), INTENT(IN) :: domain
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE ToUnit_
+END INTERFACE
+
!----------------------------------------------------------------------------
! ToUnit
!----------------------------------------------------------------------------
@@ -181,6 +303,19 @@ END FUNCTION FromUnit
! ToUnit
!----------------------------------------------------------------------------
+INTERFACE
+ MODULE PURE SUBROUTINE FromUnit_(x, domain, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ CHARACTER(*), INTENT(IN) :: domain
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE FromUnit_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! ToUnit
+!----------------------------------------------------------------------------
+
INTERFACE
MODULE RECURSIVE PURE SUBROUTINE Unit2Equilateral(d, x)
INTEGER(I4B), INTENT(IN) :: d
@@ -212,4 +347,18 @@ MODULE PURE FUNCTION Coord_Map(x, from, to) RESULT(ans)
END FUNCTION Coord_Map
END INTERFACE
+!----------------------------------------------------------------------------
+! Coord_Map
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE Coord_Map_(x, from, to, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ CHARACTER(*), INTENT(IN) :: from
+ CHARACTER(*), INTENT(IN) :: to
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE Coord_Map_
+END INTERFACE
+
END MODULE RecursiveNodesUtility
diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90
index 1fba7da35..c30160f2b 100644
--- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90
@@ -26,11 +26,15 @@ MODULE TetrahedronInterpolationUtility
PUBLIC :: LagrangeInDOF_Tetrahedron
PUBLIC :: EquidistanceInPoint_Tetrahedron
PUBLIC :: EquidistancePoint_Tetrahedron
+PUBLIC :: EquidistancePoint_Tetrahedron_
PUBLIC :: LagrangeCoeff_Tetrahedron
-PUBLIC :: Isaac_Tetrahedron
-PUBLIC :: BlythPozrikidis_Tetrahedron
+PUBLIC :: LagrangeCoeff_Tetrahedron_
PUBLIC :: InterpolationPoint_Tetrahedron
+PUBLIC :: InterpolationPoint_Tetrahedron_
+
PUBLIC :: OrthogonalBasis_Tetrahedron
+PUBLIC :: OrthogonalBasis_Tetrahedron_
+
PUBLIC :: BarycentricVertexBasis_Tetrahedron
PUBLIC :: BarycentricEdgeBasis_Tetrahedron
PUBLIC :: BarycentricFacetBasis_Tetrahedron
@@ -40,19 +44,34 @@ MODULE TetrahedronInterpolationUtility
PUBLIC :: EdgeBasis_Tetrahedron
PUBLIC :: FacetBasis_Tetrahedron
PUBLIC :: CellBasis_Tetrahedron
+
PUBLIC :: HeirarchicalBasis_Tetrahedron
+PUBLIC :: HeirarchicalBasis_Tetrahedron_
+
PUBLIC :: FacetConnectivity_Tetrahedron
PUBLIC :: EdgeConnectivity_Tetrahedron
PUBLIC :: GetVertexDOF_Tetrahedron
PUBLIC :: GetEdgeDOF_Tetrahedron
PUBLIC :: GetFacetDOF_Tetrahedron
PUBLIC :: GetCellDOF_Tetrahedron
+
PUBLIC :: LagrangeEvalAll_Tetrahedron
+PUBLIC :: LagrangeEvalAll_Tetrahedron_
+
PUBLIC :: QuadraturePoint_Tetrahedron
+PUBLIC :: QuadraturePoint_Tetrahedron_
+PUBLIC :: QuadratureNumber_Tetrahedron
+
PUBLIC :: RefElemDomain_Tetrahedron
PUBLIC :: LagrangeGradientEvalAll_Tetrahedron
+PUBLIC :: LagrangeGradientEvalAll_Tetrahedron_
+
PUBLIC :: HeirarchicalBasisGradient_Tetrahedron
+PUBLIC :: HeirarchicalBasisGradient_Tetrahedron_
+
PUBLIC :: OrthogonalBasisGradient_Tetrahedron
+PUBLIC :: OrthogonalBasisGradient_Tetrahedron_
+
PUBLIC :: GetTotalDOF_Tetrahedron
PUBLIC :: GetTotalInDOF_Tetrahedron
@@ -280,6 +299,18 @@ MODULE PURE FUNCTION LagrangeDegree_Tetrahedron(order) RESULT(ans)
END FUNCTION LagrangeDegree_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE LagrangeDegree_Tetrahedron_(order, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeDegree_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! LagrangeDOF_Tetrahedron
!----------------------------------------------------------------------------
@@ -402,6 +433,25 @@ MODULE FUNCTION EquidistancePoint_Tetrahedron(order, xij) RESULT(ans)
END FUNCTION EquidistancePoint_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE EquidistancePoint_Tetrahedron_(order, xij, ans, nrow, &
+ ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE EquidistancePoint_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! EquidistancePoint_Tetrahedron
!----------------------------------------------------------------------------
@@ -443,14 +493,8 @@ END FUNCTION EquidistancePoint_Tetrahedron_old
! summary: Interpolation point
INTERFACE
- MODULE FUNCTION InterpolationPoint_Tetrahedron( &
- & order, &
- & ipType, &
- & layout, &
- & xij, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION InterpolationPoint_Tetrahedron(order, ipType, layout, &
+ xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of element
INTEGER(I4B), INTENT(IN) :: ipType
@@ -477,6 +521,38 @@ MODULE FUNCTION InterpolationPoint_Tetrahedron( &
END FUNCTION InterpolationPoint_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+! InterpolationPoint_Tetrahedron
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Interpolation point
+
+INTERFACE
+ MODULE SUBROUTINE InterpolationPoint_Tetrahedron_(order, ipType, ans, &
+ nrow, ncol, layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of element
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation type
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !!
+ CHARACTER(*), INTENT(IN) :: layout
+ !! "VEFC", "INCREASING"
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(3, 4)
+ !! coordinates of vertices in $x_{iJ}$ format
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE InterpolationPoint_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Tetrahedron
!----------------------------------------------------------------------------
@@ -567,6 +643,99 @@ MODULE FUNCTION LagrangeCoeff_Tetrahedron4( &
END FUNCTION LagrangeCoeff_Tetrahedron4
END INTERFACE LagrangeCoeff_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Tetrahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Tetrahedron1_(order, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Tetrahedron1_
+END INTERFACE LagrangeCoeff_Tetrahedron_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Tetrahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Tetrahedron2_(order, i, v, isVandermonde, &
+ ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ ! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Tetrahedron2_
+END INTERFACE LagrangeCoeff_Tetrahedron_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Tetrahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Tetrahedron3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Tetrahedron3_
+END INTERFACE LagrangeCoeff_Tetrahedron_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Tetrahedron_
+ MODULE SUBROUTINE LagrangeCoeff_Tetrahedron4_(order, xij, basisType, &
+ refTetrahedron, alpha, beta, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials
+ !! Jacobi (Dubiner)
+ !! Heirarchical
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron
+ !! UNIT * default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Tetrahedron4_
+END INTERFACE LagrangeCoeff_Tetrahedron_
+
!----------------------------------------------------------------------------
! Isaac_Tetrahedron
!----------------------------------------------------------------------------
@@ -580,9 +749,8 @@ END FUNCTION LagrangeCoeff_Tetrahedron4
! https://tisaac.gitlab.io/recursivenodes/
INTERFACE
- MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, &
- & alpha, beta, lambda) &
- & RESULT(ans)
+ MODULE SUBROUTINE Isaac_Tetrahedron(order, ipType, ans, nrow, ncol, &
+ layout, xij, alpha, beta, lambda)
INTEGER(I4B), INTENT(IN) :: order
!! order
INTEGER(I4B), INTENT(IN) :: ipType
@@ -593,6 +761,10 @@ MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, &
!! GaussChebyshevLobatto
!! GaussJacobi
!! GaussJacobiLobatto
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! xij coordinates
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! nodal coordinates of Tetrahedron
CHARACTER(*), INTENT(IN) :: layout
@@ -604,9 +776,7 @@ MODULE FUNCTION Isaac_Tetrahedron(order, ipType, layout, xij, &
!! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical polynomial parameter
- REAL(DFP), ALLOCATABLE :: ans(:, :)
- !! xij coordinates
- END FUNCTION Isaac_Tetrahedron
+ END SUBROUTINE Isaac_Tetrahedron
END INTERFACE
!----------------------------------------------------------------------------
@@ -658,17 +828,12 @@ END FUNCTION BlythPozrikidis_Tetrahedron
!----------------------------------------------------------------------------
INTERFACE
- MODULE RECURSIVE SUBROUTINE IJK2VEFC_Tetrahedron( &
- & xi, &
- & eta, &
- & zeta, &
- & temp, &
- & order, &
- & N)
+ MODULE RECURSIVE SUBROUTINE IJK2VEFC_Tetrahedron(xi, eta, zeta, temp, &
+ order, N)
REAL(DFP), INTENT(IN) :: xi(:, :, :)
REAL(DFP), INTENT(IN) :: eta(:, :, :)
REAL(DFP), INTENT(IN) :: zeta(:, :, :)
- REAL(DFP), INTENT(OUT) :: temp(:, :)
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
INTEGER(I4B), INTENT(IN) :: order
INTEGER(I4B), INTENT(IN) :: N
END SUBROUTINE IJK2VEFC_Tetrahedron
@@ -706,6 +871,34 @@ MODULE FUNCTION OrthogonalBasis_Tetrahedron1( &
END FUNCTION OrthogonalBasis_Tetrahedron1
END INTERFACE OrthogonalBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE OrthogonalBasis_Tetrahedron_
+ MODULE SUBROUTINE OrthogonalBasis_Tetrahedron1_(order, xij, &
+ refTetrahedron, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial space
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in reference Tetrahedron.
+ !! The shape functions will be evaluated
+ !! at these points.
+ !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! "UNIT"
+ !! "BIUNIT"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! shape functions
+ !! ans(:, j), jth shape functions at all points
+ !! ans(j, :), all shape functions at jth point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (order + 1) * (order + 2) * (order + 3) / 6
+ END SUBROUTINE OrthogonalBasis_Tetrahedron1_
+END INTERFACE OrthogonalBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! OrthogonalBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -715,9 +908,8 @@ END FUNCTION OrthogonalBasis_Tetrahedron1
! summary: Orthogongal basis on Tetrahedron
INTERFACE OrthogonalBasis_Tetrahedron
- MODULE FUNCTION OrthogonalBasis_Tetrahedron2( &
- & order, &
- & x, y, z, refTetrahedron) RESULT(ans)
+ MODULE FUNCTION OrthogonalBasis_Tetrahedron2(order, x, y, z, &
+ refTetrahedron) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial space
REAL(DFP), INTENT(IN) :: x(:)
@@ -738,6 +930,34 @@ MODULE FUNCTION OrthogonalBasis_Tetrahedron2( &
END FUNCTION OrthogonalBasis_Tetrahedron2
END INTERFACE OrthogonalBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE OrthogonalBasis_Tetrahedron_
+ MODULE SUBROUTINE OrthogonalBasis_Tetrahedron2_(order, x, y, z, &
+ refTetrahedron, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial space
+ REAL(DFP), INTENT(IN) :: x(:)
+ !! x coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z)
+ REAL(DFP), INTENT(IN) :: y(:)
+ !! y coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z)
+ REAL(DFP), INTENT(IN) :: z(:)
+ !! z coordinates, total points = SIZE(x)*SIZE(y)*SIZE(z)
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! "UNIT"
+ !! "BIUNIT"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! shape functions
+ !! ans(:, j), jth shape functions at all points
+ !! ans(j, :), all shape functions at jth point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x) * SIZE(y) * SIZE(z)
+ !! ncol = (order + 1) * (order + 2) * (order + 3) / 6
+ END SUBROUTINE OrthogonalBasis_Tetrahedron2_
+END INTERFACE OrthogonalBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! BarycentricVertexBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -758,6 +978,24 @@ MODULE PURE FUNCTION BarycentricVertexBasis_Tetrahedron(lambda) &
END FUNCTION BarycentricVertexBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricVertexBasis_Tetrahedron_(lambda, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentrix coords
+ !! number of rows = 4
+ !! number of columns = number of points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(lambda, 2), 4)
+ !! ans(:,v1) basis function of vertex v1 at all points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricVertexBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricVertexBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -768,7 +1006,7 @@ END FUNCTION BarycentricVertexBasis_Tetrahedron
INTERFACE
MODULE PURE FUNCTION BarycentricVertexBasisGradient_Tetrahedron(lambda) &
- & RESULT(ans)
+ RESULT(ans)
REAL(DFP), INTENT(IN) :: lambda(:, :)
!! point of evaluation in terms of barycentrix coords
!! number of rows = 4
@@ -795,15 +1033,8 @@ END FUNCTION BarycentricVertexBasisGradient_Tetrahedron
! pe1, pe2, pe3 should be greater than or equal to 2
INTERFACE
- MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron( &
- & pe1, &
- & pe2, &
- & pe3, &
- & pe4, &
- & pe5, &
- & pe6, &
- & lambda &
- & ) RESULT(ans)
+ MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron(pe1, pe2, pe3, pe4, &
+ pe5, pe6, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: pe1
!! order on edge parallel to x
INTEGER(I4B), INTENT(IN) :: pe2
@@ -825,6 +1056,35 @@ MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron( &
END FUNCTION BarycentricEdgeBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricEdgeBasis_Tetrahedron_(pe1, pe2, pe3, &
+ pe4, pe5, pe6, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pe1
+ !! order on edge parallel to x
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order on edge parallel to y
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on edge parallel to z
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: pe5
+ !! order on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: pe6
+ !! order on edge parallel to yz
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! Number of rows in lambda is equal to 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricEdgeBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricEdgeBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -834,15 +1094,8 @@ END FUNCTION BarycentricEdgeBasis_Tetrahedron
! summary: Evaluate the edge basis on Tetrahedron in terms of barycentric
INTERFACE
- MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2( &
- & pe1, &
- & pe2, &
- & pe3, &
- & pe4, &
- & pe5, &
- & pe6, &
- & lambda, &
- & phi) RESULT(ans)
+ MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2(pe1, pe2, pe3, &
+ pe4, pe5, pe6, lambda, phi) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: pe1
!! order on edge parallel to x
INTEGER(I4B), INTENT(IN) :: pe2
@@ -870,6 +1123,41 @@ MODULE PURE FUNCTION BarycentricEdgeBasis_Tetrahedron2( &
END FUNCTION BarycentricEdgeBasis_Tetrahedron2
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricEdgeBasis_Tetrahedron2_(pe1, pe2, pe3, &
+ pe4, pe5, pe6, lambda, phi, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pe1
+ !! order on edge parallel to x
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order on edge parallel to y
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on edge parallel to z
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: pe5
+ !! order on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: pe6
+ !! order on edge parallel to yz
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! size(lambda,1) = 4
+ !! 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), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricEdgeBasis_Tetrahedron2_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricEdgeBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -969,19 +1257,45 @@ END FUNCTION BarycentricFacetBasis_Tetrahedron
END INTERFACE
!----------------------------------------------------------------------------
-! BarycentricFacetBasis_Tetrahedron
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Eval basis on facet of triangle
-
INTERFACE
- MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron2( &
- & ps1, &
- & ps2, &
- & ps3, &
- & ps4, &
+ MODULE PURE SUBROUTINE BarycentricFacetBasis_Tetrahedron_(ps1, ps2, ps3, &
+ ps4, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: ps1
+ !! order on facet parallel to xy
+ INTEGER(I4B), INTENT(IN) :: ps2
+ !! order on facet parallel to xz
+ INTEGER(I4B), INTENT(IN) :: ps3
+ !! order on facet parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps4
+ !! order on facet parallel to xyz
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! Number of rows in lambda is equal to 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 &
+ !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2
+ END SUBROUTINE BarycentricFacetBasis_Tetrahedron_
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! BarycentricFacetBasis_Tetrahedron
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Eval basis on facet of triangle
+
+INTERFACE
+ MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron2( &
+ & ps1, &
+ & ps2, &
+ & ps3, &
+ & ps4, &
& lambda, &
& phi &
& ) RESULT(ans)
@@ -1010,6 +1324,37 @@ MODULE PURE FUNCTION BarycentricFacetBasis_Tetrahedron2( &
END FUNCTION BarycentricFacetBasis_Tetrahedron2
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricFacetBasis_Tetrahedron2_(ps1, ps2, ps3, &
+ ps4, lambda, phi, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: ps1
+ !! order on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: ps2
+ !! order on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: ps3
+ !! order on edge parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps4
+ !! order on edge parallel to xyz
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! Number of rows in lambda is equal to 4
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 &
+ !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricFacetBasis_Tetrahedron2_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricFacetBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1093,6 +1438,25 @@ MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron( &
END FUNCTION BarycentricCellBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricCellBasis_Tetrahedron_(pb, lambda, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pb
+ !! order on facet parallel to xy
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! Number of rows in lambda is equal to 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B
+ END SUBROUTINE BarycentricCellBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricCellBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -1124,6 +1488,34 @@ MODULE PURE FUNCTION BarycentricCellBasis_Tetrahedron2( &
END FUNCTION BarycentricCellBasis_Tetrahedron2
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricCellBasis_Tetrahedron2_(pb, lambda, phi, &
+ ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pb
+ !! order on facet parallel to xy
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! Number of rows in lambda is equal to 4
+ REAL(DFP), INTENT(IN) :: phi(1:, 0:)
+ !! Value of lobatto kernel values
+ !! size(phi1, 1) = 6*number of points
+ !! - (lambda2-lambda1)
+ !! - (lambda3-lambda1)
+ !! - (lambda4-lambda1)
+ !! - (lambda3-lambda2)
+ !! - (lambda4-lambda2)
+ !! - (lambda4-lambda3)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B
+ END SUBROUTINE BarycentricCellBasis_Tetrahedron2_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricCellBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1177,20 +1569,8 @@ END FUNCTION BarycentricCellBasisGradient_Tetrahedron2
! summary: Evaluate all modal basis (heirarchical polynomial) on Tetrahedron
INTERFACE BarycentricHeirarchicalBasis_Tetrahedron
- MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1( &
- & order, &
- & pe1, &
- & pe2, &
- & pe3, &
- & pe4, &
- & pe5, &
- & pe6, &
- & ps1, &
- & ps2, &
- & ps3, &
- & ps4, &
- & lambda &
- & ) RESULT(ans)
+ MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1(order, &
+ pe1, pe2, pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order in the cell of triangle, it should be greater than 2
INTEGER(I4B), INTENT(IN) :: pe1
@@ -1230,28 +1610,12 @@ END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron1
END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron
!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasisGradient_Tetrahedron
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Gradient of heirarchical basis in terms of barycentric coord
-
-INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron
- MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( &
- & order, &
- & pe1, &
- & pe2, &
- & pe3, &
- & pe4, &
- & pe5, &
- & pe6, &
- & ps1, &
- & ps2, &
- & ps3, &
- & ps4, &
- & lambda &
- & ) RESULT(ans)
+INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_
+ MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron1_(order, &
+ pe1, pe2, pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, lambda, ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: order
!! order in the cell of triangle, it should be greater than 2
INTEGER(I4B), INTENT(IN) :: pe1
@@ -1278,17 +1642,15 @@ MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( &
!! Barycenteric coordinates
!! number of rows = 4
!! number of cols = number of points
- REAL(DFP) :: ans( &
- & SIZE(lambda, 2), &
- & 4 &
- & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 &
- & + (ps1 - 1) * (ps1 - 2) / 2 &
- & + (ps2 - 1) * (ps2 - 2) / 2 &
- & + (ps3 - 1) * (ps3 - 2) / 2 &
- & + (ps4 - 1) * (ps4 - 2) / 2 &
- & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 4_I4B)
- END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1
-END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 &
+ !! + (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 &
+ !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2 &
+ !! + (order - 1) * (order - 2) * (order - 3) / 6_I4B
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron1_
+END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_
!----------------------------------------------------------------------------
!
@@ -1299,20 +1661,88 @@ END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1
! summary: Evaluate heirarchical basis in terms of barycentric coord
INTERFACE BarycentricHeirarchicalBasis_Tetrahedron
- MODULE PURE FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2( &
- & order, lambda) RESULT(ans)
+ MODULE PURE FUNCTION &
+ BarycentricHeirarchicalBasis_Tetrahedron2(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(:, :)
!! Barycenteric coordinates
!! number of rows = 4
!! number of cols = number of points
- REAL(DFP) :: ans( &
- & SIZE(lambda, 2), &
- & (order + 1) * (order + 2) * (order + 3) / 6_I4B)
+ REAL(DFP) :: ans(SIZE(lambda, 2), &
+ (order + 1) * (order + 2) * (order + 3) / 6_I4B)
END FUNCTION BarycentricHeirarchicalBasis_Tetrahedron2
END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_
+ MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron2_( &
+ order, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order in the cell of triangle, it should be greater than 2
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! Barycenteric coordinates
+ !! number of rows = 4
+ !! number of cols = number of points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = (order + 1) * (order + 2) * (order + 3) / 6_I4B
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricHeirarchicalBasis_Tetrahedron2_
+END INTERFACE BarycentricHeirarchicalBasis_Tetrahedron_
+
+!----------------------------------------------------------------------------
+! BarycentricHeirarchicalBasisGradient_Tetrahedron
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Gradient of heirarchical basis in terms of barycentric coord
+
+INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron
+ MODULE PURE FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1( &
+ order, pe1, pe2, pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, lambda) 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 parallel to x
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order of interpolation on edge parallel to y
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order of interpolation on edge parallel to z
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order of interpolation on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: pe5
+ !! order of interpolation on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: pe6
+ !! order of interpolation on edge parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps1
+ !! order of interpolation on facet parallel to xy
+ INTEGER(I4B), INTENT(IN) :: ps2
+ !! order of interpolation on facet parallel to xz
+ INTEGER(I4B), INTENT(IN) :: ps3
+ !! order of interpolation on facet parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps4
+ !! order of interpolation on facet parallel to xyz
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! Barycenteric coordinates
+ !! number of rows = 4
+ !! number of cols = number of points
+ REAL(DFP) :: ans( &
+ & SIZE(lambda, 2), &
+ & 4 &
+ & + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 &
+ & + (ps1 - 1) * (ps1 - 2) / 2 &
+ & + (ps2 - 1) * (ps2 - 2) / 2 &
+ & + (ps3 - 1) * (ps3 - 2) / 2 &
+ & + (ps4 - 1) * (ps4 - 2) / 2 &
+ & + (order - 1) * (order - 2) * (order - 3) / 6_I4B, 4_I4B)
+ END FUNCTION BarycentricHeirarchicalBasisGradient_Tetrahedron1
+END INTERFACE BarycentricHeirarchicalBasisGradient_Tetrahedron
+
!----------------------------------------------------------------------------
! BarycentricHeirarchicalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1357,6 +1787,24 @@ MODULE PURE FUNCTION VertexBasis_Tetrahedron(xij, refTetrahedron) &
END FUNCTION VertexBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE VertexBasis_Tetrahedron_(xij, refTetrahedron, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! point of evaluation
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! Unit or biunit
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! ans(SIZE(xij, 2), 4)
+ !! ans(:,v1) basis function of vertex v1 at all points
+ END SUBROUTINE VertexBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! EdgeBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -1398,6 +1846,37 @@ MODULE PURE FUNCTION EdgeBasis_Tetrahedron( &
END FUNCTION EdgeBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE EdgeBasis_Tetrahedron_(pe1, pe2, pe3, pe4, pe5, &
+ pe6, xij, refTetrahedron, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pe1
+ !! order on edge parallel to x
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order on edge parallel to y
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on edge parallel to z
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: pe5
+ !! order on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: pe6
+ !! order on edge parallel to yz
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! point of evaluation
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xij, 2)
+ !! ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6
+ END SUBROUTINE EdgeBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! FacetBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -1436,6 +1915,34 @@ MODULE PURE FUNCTION FacetBasis_Tetrahedron( &
END FUNCTION FacetBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE FacetBasis_Tetrahedron_(ps1, ps2, ps3, ps4, xij, &
+ refTetrahedron, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: ps1
+ !! order on facet to xy
+ INTEGER(I4B), INTENT(IN) :: ps2
+ !! order on facet to xz
+ INTEGER(I4B), INTENT(IN) :: ps3
+ !! order on facet to yz
+ INTEGER(I4B), INTENT(IN) :: ps4
+ !! order on facet to xyz
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! order on xij
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 &
+ !! + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2
+ END SUBROUTINE FacetBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! CellBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -1462,6 +1969,28 @@ MODULE PURE FUNCTION CellBasis_Tetrahedron( &
END FUNCTION CellBasis_Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE CellBasis_Tetrahedron_(pb, xij, refTetrahedron, &
+ ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: pb
+ !! order in cell
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! order on xij
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written to ans
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B
+ END SUBROUTINE CellBasis_Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -1471,21 +2000,9 @@ END FUNCTION CellBasis_Tetrahedron
! summary: Returns the heirarchical basis functions on Tetrahedron
INTERFACE HeirarchicalBasis_Tetrahedron
- MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1( &
- & order, &
- & pe1, &
- & pe2, &
- & pe3, &
- & pe4, &
- & pe5, &
- & pe6, &
- & ps1, &
- & ps2, &
- & ps3, &
- & ps4, &
- & xij, &
- & refTetrahedron) &
- & RESULT(ans)
+ MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1(order, pe1, pe2, &
+ pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order in the cell of triangle, it should be greater than 2
INTEGER(I4B), INTENT(IN) :: pe1
@@ -1524,6 +2041,49 @@ MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron1( &
END FUNCTION HeirarchicalBasis_Tetrahedron1
END INTERFACE HeirarchicalBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Tetrahedron_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Tetrahedron1_(order, pe1, pe2, &
+ pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron, ans, &
+ nrow, ncol)
+ 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 parallel to x
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order of interpolation on edge parallel to y
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order of interpolation on edge parallel to z
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order of interpolation on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: pe5
+ !! order of interpolation on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: pe6
+ !! order of interpolation on edge parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps1
+ !! order of interpolation on facet parallel to xy
+ INTEGER(I4B), INTENT(IN) :: ps2
+ !! order of interpolation on facet parallel to xz
+ INTEGER(I4B), INTENT(IN) :: ps3
+ !! order of interpolation on facet parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps4
+ !! order of interpolation on facet parallel to xyz
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! order on xij
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(xij, 2),
+ !! ncol = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 + (ps1 - 1) * (ps1 - 2) / 2
+ !! + (ps2 - 1) * (ps2 - 2) / 2 + (ps3 - 1) * (ps3 - 2) / 2 &
+ !! + (ps4 - 1) * (ps4 - 2) / 2 + (order - 1) * (order - 2) * (order - 3) / 6_I4B)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Tetrahedron1_
+END INTERFACE HeirarchicalBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Tetrahedron
!----------------------------------------------------------------------------
@@ -1533,11 +2093,8 @@ END FUNCTION HeirarchicalBasis_Tetrahedron1
! summary: Returns the heirarchical basis functions on Tetrahedron
INTERFACE HeirarchicalBasis_Tetrahedron
- MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2( &
- & order, &
- & xij, &
- & refTetrahedron) &
- & RESULT(ans)
+ MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2(order, xij, &
+ refTetrahedron) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order in the cell of triangle, it should be greater than 2
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -1550,6 +2107,26 @@ MODULE PURE FUNCTION HeirarchicalBasis_Tetrahedron2( &
END FUNCTION HeirarchicalBasis_Tetrahedron2
END INTERFACE HeirarchicalBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasis_Tetrahedron_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Tetrahedron2_(order, xij, &
+ refTetrahedron, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order in the cell of triangle, it should be greater than 2
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! order on xij
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! nrow = SIZE(xij, 2)
+ !! ncol = (order + 1) * (order + 2) * (order + 3) / 6_I4B)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Tetrahedron2_
+END INTERFACE HeirarchicalBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Tetrahedron
!----------------------------------------------------------------------------
@@ -1559,17 +2136,9 @@ END FUNCTION HeirarchicalBasis_Tetrahedron2
! summary: Evaluate all Lagrange polynomials at several points
INTERFACE LagrangeEvalAll_Tetrahedron
- MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( &
- & order, &
- & x, &
- & xij, &
- & refTetrahedron, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll_Tetrahedron1(order, x, xij, &
+ refTetrahedron, coeff, firstCall, basisType, alpha, beta, lambda) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(3)
@@ -1595,13 +2164,6 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( &
!! Default value of firstCall is True
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
!! Monomials *Default
- !! Legendre
- !! Lobatto
- !! Chebyshev
- !! Jacobi
- !! Ultraspherical
- !! Heirarchical
- !! Orthogonal
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
@@ -1613,6 +2175,54 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron1( &
END FUNCTION LagrangeEvalAll_Tetrahedron1
END INTERFACE LagrangeEvalAll_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Tetrahedron_
+ MODULE SUBROUTINE LagrangeEvalAll_Tetrahedron1_(order, x, xij, ans, &
+ tsize, refTetrahedron, coeff, firstCall, basisType, alpha, beta, &
+ lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(3)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ !! x(3) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ !! The number of rows in xij is 3
+ !! The number of columns in xij should be equal to total
+ !! degree of freedom
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Value of n+1 Lagrange polynomials at point x
+ !! size(xij, 2)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total data written in ans
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be computed and returned
+ !! by this routine.
+ !! If firstCall is False, then coeff should be given, which will be
+ !! used.
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeEvalAll_Tetrahedron1_
+END INTERFACE LagrangeEvalAll_Tetrahedron_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Tetrahedron
!----------------------------------------------------------------------------
@@ -1622,18 +2232,9 @@ END FUNCTION LagrangeEvalAll_Tetrahedron1
! summary: Evaluate all Lagrange polynomials at several points
INTERFACE LagrangeEvalAll_Tetrahedron
- MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( &
- & order, &
- & x, &
- & xij, &
- & refTetrahedron, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, &
- & beta, &
- & lambda &
- & ) RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll_Tetrahedron2(order, x, xij, &
+ refTetrahedron, coeff, firstCall, basisType, alpha, beta, lambda) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(:, :)
@@ -1654,6 +2255,51 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( &
!! Default value of firstCall is True
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
!! Monomials *Default
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ END FUNCTION LagrangeEvalAll_Tetrahedron2
+END INTERFACE LagrangeEvalAll_Tetrahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Tetrahedron_
+ MODULE SUBROUTINE LagrangeEvalAll_Tetrahedron2_(order, x, xij, ans, &
+ nrow, ncol, refTetrahedron, coeff, firstCall, basisType, alpha, beta, &
+ lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ !! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x, 2), SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns writen in ans
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron
+ !! UNIT *default
+ !! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ ! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
!! Legendre
!! Lobatto
!! Chebyshev
@@ -1667,10 +2313,24 @@ MODULE FUNCTION LagrangeEvalAll_Tetrahedron2( &
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical parameter
- REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2))
- !! Value of n+1 Lagrange polynomials at point x
- END FUNCTION LagrangeEvalAll_Tetrahedron2
-END INTERFACE LagrangeEvalAll_Tetrahedron
+ END SUBROUTINE LagrangeEvalAll_Tetrahedron2_
+END INTERFACE LagrangeEvalAll_Tetrahedron_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE FUNCTION QuadratureNumber_Tetrahedron(order, quadType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ INTEGER(I4B) :: ans
+ !! Quadrature points
+ END FUNCTION QuadratureNumber_Tetrahedron
+END INTERFACE
!----------------------------------------------------------------------------
! QuadraturePoints_Tetrahedron
@@ -1705,6 +2365,33 @@ MODULE FUNCTION QuadraturePoint_Tetrahedron1(&
END FUNCTION QuadraturePoint_Tetrahedron1
END INTERFACE QuadraturePoint_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Tetrahedron_
+ MODULE SUBROUTINE QuadraturePoint_Tetrahedron1_(order, quadType, &
+ refTetrahedron, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! Reference triangle
+ !! BIUNIT
+ !! UNIT
+ !! If xij is present then this argument is ignored
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij should be 3.
+ !! The number of columns in xij should be 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE QuadraturePoint_Tetrahedron1_
+END INTERFACE QuadraturePoint_Tetrahedron_
+
!----------------------------------------------------------------------------
! QuadraturePoints_Tetrahedron
!----------------------------------------------------------------------------
@@ -1741,6 +2428,37 @@ MODULE FUNCTION QuadraturePoint_Tetrahedron2(&
END FUNCTION QuadraturePoint_Tetrahedron2
END INTERFACE QuadraturePoint_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Tetrahedron_
+ MODULE SUBROUTINE QuadraturePoint_Tetrahedron2_(nips, quadType, &
+ refTetrahedron, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! nips(1) .LE. 79, then we call
+ !! economical quadrature rules.
+ !! Otherwise, this routine will retport
+ !! error
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type,
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! Reference triangle
+ !! BIUNIT
+ !! UNIT
+ !! If xij is present then this argument is ignored
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij should be 3
+ !! The number of columns in xij should be 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows ans columns
+ END SUBROUTINE QuadraturePoint_Tetrahedron2_
+END INTERFACE QuadraturePoint_Tetrahedron_
+
!----------------------------------------------------------------------------
! TensorQuadraturePoints_Tetrahedron
!----------------------------------------------------------------------------
@@ -1771,7 +2489,33 @@ END FUNCTION TensorQuadraturePoint_Tetrahedron1
END INTERFACE TensorQuadraturePoint_Tetrahedron
!----------------------------------------------------------------------------
-! TensorQuadraturePoints_Tetrahedron
+!
+!----------------------------------------------------------------------------
+
+INTERFACE TensorQuadraturePoint_Tetrahedron_
+ MODULE SUBROUTINE TensorQuadraturePoint_Tetrahedron1_(order, quadType, &
+ refTetrahedron, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! Reference triangle
+ !! BIUNIT
+ !! UNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij can be 4.
+ !! The number of columns in xij should be 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE TensorQuadraturePoint_Tetrahedron1_
+END INTERFACE TensorQuadraturePoint_Tetrahedron_
+
+!----------------------------------------------------------------------------
+! TensorQuadraturePoints_Tetrahedron
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1796,9 +2540,7 @@ MODULE FUNCTION TensorQuadraturePoint_Tetrahedron2( &
!! quadrature point type
!! currently this variable is not used
CHARACTER(*), INTENT(IN) :: refTetrahedron
- !! Reference triangle
- !! BIUNIT
- !! UNIT
+ !! Reference triangle ! BIUNIT ! UNIT
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! nodal coordinates of triangle.
!! The number of rows in xij should be 3
@@ -1808,6 +2550,36 @@ MODULE FUNCTION TensorQuadraturePoint_Tetrahedron2( &
END FUNCTION TensorQuadraturePoint_Tetrahedron2
END INTERFACE TensorQuadraturePoint_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE TensorQuadraturePoint_Tetrahedron_
+ MODULE SUBROUTINE TensorQuadraturePoint_Tetrahedron2_(nipsx, nipsy, &
+ nipsz, quadType, refTetrahedron, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nipsx(1)
+ !! number of integration points in x direction
+ INTEGER(I4B), INTENT(IN) :: nipsy(1)
+ !! number of integration points in y direction
+ INTEGER(I4B), INTENT(IN) :: nipsz(1)
+ !! number of integration points in z direction
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! Reference triangle
+ !! BIUNIT
+ !! UNIT
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij should be 3
+ !! The number of columns in xij should be 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE TensorQuadraturePoint_Tetrahedron2_
+END INTERFACE TensorQuadraturePoint_Tetrahedron_
+
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Tetrahedron
!----------------------------------------------------------------------------
@@ -1839,8 +2611,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( &
REAL(DFP), INTENT(INOUT) :: xij(:, :)
!! Interpolation points
CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron
- !! UNIT *default
- !! BIUNIT
+ !! UNIT *default ! BIUNIT
REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
!! Coefficient of Lagrange polynomials
LOGICAL(LGT), OPTIONAL :: firstCall
@@ -1849,12 +2620,7 @@ MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( &
!! Default value of firstCall is True
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
!! Monomials *Default
- !! Legendre
- !! Lobatto
- !! Chebyshev
- !! Jacobi
- !! Ultraspherical
- !! Heirarchical
+ !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical ! Heirarchical
!! Orthogonal
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi parameter
@@ -1871,6 +2637,49 @@ MODULE FUNCTION LagrangeGradientEvalAll_Tetrahedron1( &
END FUNCTION LagrangeGradientEvalAll_Tetrahedron1
END INTERFACE LagrangeGradientEvalAll_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeGradientEvalAll_Tetrahedron_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Tetrahedron1_(order, x, xij, &
+ ans, dim1, dim2, dim3, refTetrahedron, coeff, firstCall, basisType, &
+ alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord ! x(2, :) is y coord ! x(3, :) is z coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1, dim2, dim3 = SIZE(x, 2), SIZE(xij, 2), 3
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: refTetrahedron
+ !! UNIT *default ! BIUNIT
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default ! Orthogonal
+ !! Legendre ! Lobatto ! Chebyshev ! Jacobi ! Ultraspherical ! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Tetrahedron1_
+END INTERFACE LagrangeGradientEvalAll_Tetrahedron_
+
!----------------------------------------------------------------------------
! OrthogonalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1880,10 +2689,8 @@ END FUNCTION LagrangeGradientEvalAll_Tetrahedron1
! summary: Orthogongal basis on Tetrahedron
INTERFACE OrthogonalBasisGradient_Tetrahedron
- MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1( &
- & order, &
- & xij, &
- & refTetrahedron) RESULT(ans)
+ MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1(order, xij, &
+ refTetrahedron) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial space
REAL(DFP), INTENT(IN) :: xij(:, :)
@@ -1894,15 +2701,43 @@ MODULE FUNCTION OrthogonalBasisGradient_Tetrahedron1( &
CHARACTER(*), INTENT(IN) :: refTetrahedron
!! "UNIT"
!! "BIUNIT"
- REAL(DFP) :: ans( &
- & SIZE(xij, 2), &
- & (order + 1) * (order + 2) * (order + 3) / 6, 3)
+ REAL(DFP) :: ans(SIZE(xij, 2), &
+ (order + 1) * (order + 2) * (order + 3) / 6, 3)
!! shape functions
!! ans(:, j), jth shape functions at all points
!! ans(j, :), all shape functions at jth point
END FUNCTION OrthogonalBasisGradient_Tetrahedron1
END INTERFACE OrthogonalBasisGradient_Tetrahedron
+!----------------------------------------------------------------------------
+! OrthogonalBasisGradient_Tetrahedron_
+!----------------------------------------------------------------------------
+
+INTERFACE OrthogonalBasisGradient_Tetrahedron_
+ MODULE SUBROUTINE OrthogonalBasisGradient_Tetrahedron1_(order, xij, &
+ refTetrahedron, ans, dim1, dim2, dim3)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial space
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in reference Tetrahedron.
+ !! The shape functions will be evaluated
+ !! at these points.
+ !! the SIZE(xij,1) = 3, and SIZE(xij, 2) = number of points
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! "UNIT"
+ !! "BIUNIT"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! gradient of shape functions
+ !! first dimension = evaluation point
+ !! second dimension = shape function number
+ !! third dimension = spatial dimension
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = size(xij, 2)
+ !! dim2 = (order + 1) * (order + 2) * (order + 3) / 6
+ !! dim3 = 3
+ END SUBROUTINE OrthogonalBasisGradient_Tetrahedron1_
+END INTERFACE OrthogonalBasisGradient_Tetrahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1912,21 +2747,9 @@ END FUNCTION OrthogonalBasisGradient_Tetrahedron1
! summary: Returns the heirarchical basis functions on Tetrahedron
INTERFACE HeirarchicalBasisGradient_Tetrahedron
- MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1( &
- & order, &
- & pe1, &
- & pe2, &
- & pe3, &
- & pe4, &
- & pe5, &
- & pe6, &
- & ps1, &
- & ps2, &
- & ps3, &
- & ps4, &
- & xij, &
- & refTetrahedron) &
- & RESULT(ans)
+ MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1(order, pe1, pe2, &
+ pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order in the cell of triangle, it should be greater than 2
INTEGER(I4B), INTENT(IN) :: pe1
@@ -1965,6 +2788,55 @@ MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron1( &
END FUNCTION HeirarchicalBasisGradient_Tetrahedron1
END INTERFACE HeirarchicalBasisGradient_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Tetrahedron_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Tetrahedron1_(order, pe1, pe2, &
+ pe3, pe4, pe5, pe6, ps1, ps2, ps3, ps4, xij, refTetrahedron, &
+ ans, dim1, dim2, dim3)
+
+ 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 parallel to x
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order of interpolation on edge parallel to y
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order of interpolation on edge parallel to z
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order of interpolation on edge parallel to xy
+ INTEGER(I4B), INTENT(IN) :: pe5
+ !! order of interpolation on edge parallel to xz
+ INTEGER(I4B), INTENT(IN) :: pe6
+ !! order of interpolation on edge parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps1
+ !! order of interpolation on facet parallel to xy
+ INTEGER(I4B), INTENT(IN) :: ps2
+ !! order of interpolation on facet parallel to xz
+ INTEGER(I4B), INTENT(IN) :: ps3
+ !! order of interpolation on facet parallel to yz
+ INTEGER(I4B), INTENT(IN) :: ps4
+ !! order of interpolation on facet parallel to xyz
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! order on xij
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 &
+ !! + (ps1 - 1) * (ps1 - 2) / 2 &
+ !! + (ps2 - 1) * (ps2 - 2) / 2 &
+ !! + (ps3 - 1) * (ps3 - 2) / 2 &
+ !! + (ps4 - 1) * (ps4 - 2) / 2 &
+ !! + (order - 1) * (order - 2) * (order - 3) / 6_I4B
+ !! dim3 = 3
+ END SUBROUTINE HeirarchicalBasisGradient_Tetrahedron1_
+END INTERFACE HeirarchicalBasisGradient_Tetrahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1973,12 +2845,30 @@ END FUNCTION HeirarchicalBasisGradient_Tetrahedron1
! date: 28 Oct 2022
! summary: Returns the heirarchical basis functions on Tetrahedron
+INTERFACE HeirarchicalBasisGradient_Tetrahedron_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Tetrahedron2_(order, xij, &
+ refTetrahedron, ans, dim1, dim2, dim3)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order in the cell of triangle, it should be greater than 2
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! order on xij
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! UNIT or BIUNIT
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(xij, 2)
+ !! dim2 = (order + 1) * (order + 2) * (order + 3) / 6_I4B
+ !! dim3 = 3
+ END SUBROUTINE HeirarchicalBasisGradient_Tetrahedron2_
+END INTERFACE HeirarchicalBasisGradient_Tetrahedron_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
INTERFACE HeirarchicalBasisGradient_Tetrahedron
- MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron2( &
- & order, &
- & xij, &
- & refTetrahedron) &
- & RESULT(ans)
+ MODULE FUNCTION HeirarchicalBasisGradient_Tetrahedron2(order, xij, refTetrahedron) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order in the cell of triangle, it should be greater than 2
REAL(DFP), INTENT(IN) :: xij(:, :)
diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90
index 463931d91..f52b2de36 100644
--- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90
+++ b/src/modules/Polynomial/src/TriangleInterpolationUtility.F90
@@ -16,7 +16,7 @@
!
MODULE TriangleInterpolationUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
USE String_Class, ONLY: String
IMPLICIT NONE
PRIVATE
@@ -24,23 +24,44 @@ MODULE TriangleInterpolationUtility
PUBLIC :: LagrangeDOF_Triangle
PUBLIC :: LagrangeInDOF_Triangle
PUBLIC :: EquidistanceInPoint_Triangle
+
PUBLIC :: EquidistancePoint_Triangle
+PUBLIC :: EquidistancePoint_Triangle_
+
PUBLIC :: InterpolationPoint_Triangle
+PUBLIC :: InterpolationPoint_Triangle_
PUBLIC :: LagrangeCoeff_Triangle
+PUBLIC :: LagrangeCoeff_Triangle_
PUBLIC :: Dubiner_Triangle
+PUBLIC :: Dubiner_Triangle_
+
PUBLIC :: OrthogonalBasis_Triangle
+PUBLIC :: OrthogonalBasis_Triangle_
+
PUBLIC :: OrthogonalBasisGradient_Triangle
+PUBLIC :: OrthogonalBasisGradient_Triangle_
PUBLIC :: VertexBasis_Triangle
PUBLIC :: EdgeBasis_Triangle
PUBLIC :: CellBasis_Triangle
+
PUBLIC :: HeirarchicalBasis_Triangle
+PUBLIC :: HeirarchicalBasis_Triangle_
+
PUBLIC :: HeirarchicalBasisGradient_Triangle
+PUBLIC :: HeirarchicalBasisGradient_Triangle_
PUBLIC :: LagrangeEvalAll_Triangle
+PUBLIC :: LagrangeEvalAll_Triangle_
+
PUBLIC :: LagrangeGradientEvalAll_Triangle
+PUBLIC :: LagrangeGradientEvalAll_Triangle_
+
+PUBLIC :: QuadratureNumber_Triangle
PUBLIC :: QuadraturePoint_Triangle
+PUBLIC :: QuadraturePoint_Triangle_
+
PUBLIC :: IJ2VEFC_Triangle
PUBLIC :: FacetConnectivity_Triangle
PUBLIC :: RefElemDomain_Triangle
@@ -48,13 +69,8 @@ MODULE TriangleInterpolationUtility
PUBLIC :: GetTotalDOF_Triangle
PUBLIC :: GetTotalInDOF_Triangle
-! PUBLIC :: BarycentricVertexBasis_Triangle
-! PUBLIC :: BarycentricEdgeBasis_Triangle
-! PUBLIC :: BarycentricHeirarchicalBasis_Triangle
-! PUBLIC :: BarycentricHeirarchicalBasisGradient_Triangle
-
!----------------------------------------------------------------------------
-! GetTotalDOF_Triangle
+! GetTotalDOF_Triangle
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -147,7 +163,7 @@ END FUNCTION FacetConnectivity_Triangle
MODULE SUBROUTINE IJ2VEFC_Triangle(xi, eta, temp, order, N)
REAL(DFP), INTENT(IN) :: xi(:, :)
REAL(DFP), INTENT(IN) :: eta(:, :)
- REAL(DFP), INTENT(OUT) :: temp(:, :)
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
INTEGER(I4B), INTENT(IN) :: order
INTEGER(I4B), INTENT(IN) :: N
END SUBROUTINE IJ2VEFC_Triangle
@@ -254,6 +270,36 @@ MODULE PURE FUNCTION EquidistanceInPoint_Triangle(order, xij) RESULT(ans)
END FUNCTION EquidistanceInPoint_Triangle
END INTERFACE
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Triangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance points in triangle
+!
+!# Introduction
+!
+!- This function returns the equidistance points in triangle
+!- All points are inside the triangle
+
+INTERFACE
+ MODULE PURE SUBROUTINE EquidistanceInPoint_Triangle_(order, ans, nrow, &
+ ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in $x_{iJ}$ format
+ !! If xij is present then number of rows in ans is same as xij
+ !! If xij is not present then number of rows in ans is 2.
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 3
+ END SUBROUTINE EquidistanceInPoint_Triangle_
+END INTERFACE
+
!----------------------------------------------------------------------------
! EquidistancePoint_Triangle
!----------------------------------------------------------------------------
@@ -284,6 +330,26 @@ MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Triangle(order, xij) RESULT(ans
END FUNCTION EquidistancePoint_Triangle
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE RECURSIVE PURE SUBROUTINE EquidistancePoint_Triangle_(order, ans, &
+ nrow, ncol, xij)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and cols
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of point 1 and point 2 in $x_{iJ}$ format
+ !! number of rows = nsd
+ !! number of cols = 3
+ END SUBROUTINE EquidistancePoint_Triangle_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BlythPozrikidis_Triangle
!----------------------------------------------------------------------------
@@ -301,9 +367,8 @@ END FUNCTION EquidistancePoint_Triangle
! doi:10.1093/imamat/hxh077.
INTERFACE
- MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, &
- & alpha, beta, lambda) &
- & RESULT(ans)
+ MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, &
+ alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order
INTEGER(I4B), INTENT(IN) :: ipType
@@ -325,6 +390,37 @@ MODULE FUNCTION BlythPozrikidis_Triangle(order, ipType, layout, xij, &
END FUNCTION BlythPozrikidis_Triangle
END INTERFACE
+!----------------------------------------------------------------------------
+! BlythPozrikidis_Triangle_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE BlythPozrikidis_Triangle_(order, ipType, ans, nrow, ncol, &
+ layout, xij, alpha, beta, lambda)
+
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev,
+ !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! xij coordinates
+ CHARACTER(*), INTENT(IN) :: layout
+ !! local node numbering layout
+ !! only layout = "VEFC" is allowed
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE BlythPozrikidis_Triangle_
+END INTERFACE
+
!----------------------------------------------------------------------------
! Isaac_Triangle
!----------------------------------------------------------------------------
@@ -334,8 +430,8 @@ END FUNCTION BlythPozrikidis_Triangle
! summary: Isaac points on triangle
INTERFACE
- MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, &
- & alpha, beta, lambda) &
+ MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, &
+ alpha, beta, lambda) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order
@@ -358,6 +454,36 @@ MODULE FUNCTION Isaac_Triangle(order, ipType, layout, xij, &
END FUNCTION Isaac_Triangle
END INTERFACE
+!----------------------------------------------------------------------------
+! Isaac_Triangle
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE Isaac_Triangle_(order, ipType, ans, nrow, ncol, &
+ layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev,
+ !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! xij coordinates
+ CHARACTER(*), INTENT(IN) :: layout
+ !! local node numbering layout
+ !! only layout = "VEFC" is allowed
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE Isaac_Triangle_
+END INTERFACE
+
!----------------------------------------------------------------------------
! InterpolationPoint_Triangle
!----------------------------------------------------------------------------
@@ -391,7 +517,7 @@ END FUNCTION Isaac_Triangle
INTERFACE
MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, &
- & layout, xij, alpha, beta, lambda) RESULT(ans)
+ layout, xij, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order
INTEGER(I4B), INTENT(IN) :: ipType
@@ -411,6 +537,34 @@ MODULE FUNCTION InterpolationPoint_Triangle(order, ipType, &
END FUNCTION InterpolationPoint_Triangle
END INTERFACE
+!----------------------------------------------------------------------------
+! InterpolationPoint_Triangle_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE InterpolationPoint_Triangle_(order, ipType, ans, nrow, &
+ ncol, layout, xij, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! interpolation point type
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! xij coordinates
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! Coord of domain in xij format
+ CHARACTER(*), INTENT(IN) :: layout
+ !! local node numbering layout, always VEFC
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical polynomial parameter
+ END SUBROUTINE InterpolationPoint_Triangle_
+END INTERFACE
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Triangle
!----------------------------------------------------------------------------
@@ -432,6 +586,25 @@ MODULE FUNCTION LagrangeCoeff_Triangle1(order, i, xij) RESULT(ans)
END FUNCTION LagrangeCoeff_Triangle1
END INTERFACE LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle_
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Triangle_
+ MODULE SUBROUTINE LagrangeCoeff_Triangle1_(order, i, xij, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Triangle1_
+END INTERFACE LagrangeCoeff_Triangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Triangle
!----------------------------------------------------------------------------
@@ -457,6 +630,29 @@ MODULE FUNCTION LagrangeCoeff_Triangle2(order, i, v, isVandermonde) &
END FUNCTION LagrangeCoeff_Triangle2
END INTERFACE LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle_
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Triangle_
+ MODULE SUBROUTINE LagrangeCoeff_Triangle2_(order, i, v, isVandermonde, &
+ ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial, it should be SIZE(v,2)-1
+ INTEGER(I4B), INTENT(IN) :: i
+ !! 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, the value of isVandermonde
+ !! is not used in thesubroutine _
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ ! ans(SIZE(v, 1))
+ !! coefficients of ith Lagrange polynomial
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Triangle2_
+END INTERFACE LagrangeCoeff_Triangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Triangle
!----------------------------------------------------------------------------
@@ -480,6 +676,27 @@ MODULE FUNCTION LagrangeCoeff_Triangle3(order, i, v, ipiv) RESULT(ans)
END FUNCTION LagrangeCoeff_Triangle3
END INTERFACE LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Triangle_
+ MODULE SUBROUTINE LagrangeCoeff_Triangle3_(order, i, v, ipiv, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(v, 1))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE LagrangeCoeff_Triangle3_
+END INTERFACE LagrangeCoeff_Triangle_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Triangle
!----------------------------------------------------------------------------
@@ -653,6 +870,10 @@ MODULE PURE SUBROUTINE Dubiner_Triangle1_(order, xij, refTriangle, ans, &
END SUBROUTINE Dubiner_Triangle1_
END INTERFACE Dubiner_Triangle_
+INTERFACE OrthogonalBasis_Triangle_
+ MODULE PROCEDURE Dubiner_Triangle1_
+END INTERFACE OrthogonalBasis_Triangle_
+
!----------------------------------------------------------------------------
! DubinerPolynomial
!----------------------------------------------------------------------------
@@ -726,25 +947,9 @@ MODULE PURE SUBROUTINE Dubiner_Triangle2_(order, x, y, refTriangle, ans, &
END SUBROUTINE 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 SUBROUTINE BarycentricVertexBasis_Triangle(lambda, ans)
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation in terms of barycentrix coords
- !! number of rows = 3 corresponding to three coordinates
- !! number of columns = number of points
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), 3)
- !! ans(:,v1) basis function of vertex v1 at all points
- END SUBROUTINE BarycentricVertexBasis_Triangle
-END INTERFACE
+INTERFACE OrthogonalBasis_Triangle_
+ MODULE PROCEDURE Dubiner_Triangle2_
+END INTERFACE OrthogonalBasis_Triangle_
!----------------------------------------------------------------------------
! VertexBasis_Triangle
@@ -765,37 +970,6 @@ MODULE PURE FUNCTION VertexBasis_Triangle(xij, refTriangle) RESULT(ans)
END FUNCTION VertexBasis_Triangle
END INTERFACE
-!----------------------------------------------------------------------------
-! 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 SUBROUTINE BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, &
- lambda, 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
- !! Number of rows in lambda is equal to three corresponding to
- !! three coordinates
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3)
- END SUBROUTINE BarycentricEdgeBasis_Triangle
-END INTERFACE
-
!----------------------------------------------------------------------------
! EdgeBasis_Triangle
!----------------------------------------------------------------------------
@@ -812,7 +986,7 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle
INTERFACE
MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: pe1
!! order on left vertical edge (e1), should be greater than 1
INTEGER(I4B), INTENT(IN) :: pe2
@@ -827,27 +1001,6 @@ MODULE PURE FUNCTION EdgeBasis_Triangle(pe1, pe2, pe3, xij, refTriangle) &
END FUNCTION EdgeBasis_Triangle
END INTERFACE
-!----------------------------------------------------------------------------
-! BarycentricCellBasis_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Returns the Cell basis functions on reference Triangle
-
-INTERFACE
- MODULE PURE SUBROUTINE BarycentricCellBasis_Triangle(order, lambda, ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order in this cell, it should be greater than 2
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation in terms of barycentrix coords
- !! number of rows = 3 corresponding to three coordinates
- !! number of columns = number of points
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2))
- END SUBROUTINE BarycentricCellBasis_Triangle
-END INTERFACE
-
!----------------------------------------------------------------------------
! CellBasis_Triangle
!----------------------------------------------------------------------------
@@ -872,67 +1025,6 @@ MODULE PURE FUNCTION CellBasis_Triangle(order, xij, refTriangle) RESULT(ans)
END FUNCTION CellBasis_Triangle
END INTERFACE
-!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
-
-INTERFACE BarycentricHeirarchicalBasis_Triangle
- MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle1(order, &
- & pe1, pe2, pe3, lambda, refTriangle, ans, nrow, ncol)
- 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) :: lambda(:, :)
- !! Barycenteric coordinates
- !! number of rows = 3
- !! number of cols = number of points
- CHARACTER(*), INTENT(IN) :: refTriangle
- !! reference triangle, "BIUNIT", "UNIT"
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP) :: ans( &
- ! & SIZE(lambda, 2), &
- ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2))
- !!
- INTEGER(I4B), INTENT(OUT) :: nrow, ncol
- END SUBROUTINE BarycentricHeirarchicalBasis_Triangle1
-END INTERFACE BarycentricHeirarchicalBasis_Triangle
-
-!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
-
-INTERFACE BarycentricHeirarchicalBasis_Triangle
-MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle2(order, lambda, &
- & refTriangle, ans, nrow, ncol)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of approximation on triangle
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! Barycenteric coordinates
- !! number of rows = 3
- !! number of cols = number of points
- CHARACTER(*), INTENT(IN) :: refTriangle
- !! reference triangle, "BIUNIT", "UNIT"
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP) :: ans( &
- ! & SIZE(lambda, 2), &
- ! & INT((order + 1) * (order + 2) / 2))
- INTEGER(I4B), INTENT(OUT) :: nrow, ncol
- END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2
-END INTERFACE BarycentricHeirarchicalBasis_Triangle
-
!----------------------------------------------------------------------------
! HeirarchicalBasis_Triangle
!----------------------------------------------------------------------------
@@ -942,8 +1034,8 @@ END SUBROUTINE BarycentricHeirarchicalBasis_Triangle2
! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
INTERFACE HeirarchicalBasis_Triangle
- MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3,&
- & xij, refTriangle) RESULT(ans)
+ MODULE PURE FUNCTION HeirarchicalBasis_Triangle1(order, pe1, pe2, pe3, &
+ xij, refTriangle) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of approximation inside the triangle (i.e., cell)
!! it should be greater than 2 for cell bubble to exist
@@ -1067,107 +1159,48 @@ END SUBROUTINE HeirarchicalBasis_Triangle2_
END INTERFACE HeirarchicalBasis_Triangle_
!----------------------------------------------------------------------------
-!
+! HeirarchicalBasis_Triangle
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 2024-04-21
-! summary: Evaluate the gradient of the edge basis on triangle
-! using barycentric coordinate
-
-INTERFACE
- MODULE PURE SUBROUTINE BarycentricVertexBasisGradient_Triangle(lambda, ans)
- 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(INOUT) :: ans(:, :, :)
- ! ans(SIZE(lambda, 2), 3, 3)
- END SUBROUTINE BarycentricVertexBasisGradient_Triangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
+! date: 2024-07-04
+! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
-!> author: Shion Shimizu
-! date: 2024-04-21
-! summary: Evaluate the gradient of the edge basis on triangle
-! using barycentric coordinate
-
-INTERFACE
- MODULE PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle(pe1, pe2, pe3, &
- lambda, 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(INOUT) :: ans(:, :, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3)
- END SUBROUTINE BarycentricEdgeBasisGradient_Triangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Shion Shimizu
-! date: 2024-04-21
-! summary: Evaluate the gradient of the edge basis on triangle
-! using barycentric coordinate
-
-INTERFACE
- MODULE PURE SUBROUTINE BarycentricCellBasisGradient_Triangle(order, lambda, &
- ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order on Cell (e1)
- 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(INOUT) :: ans(:, :, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), 3*order - 3, 3)
- END SUBROUTINE BarycentricCellBasisGradient_Triangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasisGradient_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Shion Shimizu and Vikas Sharma
-! date: 2024-04-21
-! summary: Evaluate the gradient of the Hierarchical basis on triangle
-
-INTERFACE BarycentricHeirarchicalBasisGradient_Triangle
-MODULE PURE SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1(order, &
- & pe1, pe2, pe3, lambda, refTriangle, ans)
+INTERFACE HeirarchicalBasis_Triangle_
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle3_(order, pe1, pe2, pe3, &
+ xij, refTriangle, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, &
+ ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: order
- !! order in the cell of triangle, it should be greater than 2
+ !! Order of approximation inside the triangle (i.e., cell)
+ !! it should be greater than 2 for cell bubble to exist
INTEGER(I4B), INTENT(IN) :: pe1
- !! order of interpolation on edge e1
+ !! Order of interpolation on edge e1
+ !! It should be greater than 1 for edge bubble to exists
INTEGER(I4B), INTENT(IN) :: pe2
- !! order of interpolation on edge e2
+ !! Order of interpolation on edge e2
+ !! It should be greater than 1 for edge bubble to exists
INTEGER(I4B), INTENT(IN) :: pe3
- !! order of interpolation on edge e3
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! Barycenteric coordinates
- !! number of rows = 3
- !! number of cols = number of points
+ !! Order of interpolation on edge e3
+ !! It should be greater than 1 for edge bubble to exists
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
CHARACTER(*), INTENT(IN) :: refTriangle
- !! reference triangle, "BIUNIT", "UNIT"
- REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! This parameter denotes the type of reference triangle.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Triangle.
+ !! BIUNIT: in this case xij is in biunit triangle.
+ INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3
+ !! edge orientation, 1 or -1
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:)
+ !! face orient, size is 2, 1 or -1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
! REAL(DFP) :: ans( &
- ! & SIZE(lambda, 2), &
- ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 3)
+ ! & SIZE(xij, 2), &
+ ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2))
!!
- END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1
-END INTERFACE BarycentricHeirarchicalBasisGradient_Triangle
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Triangle3_
+END INTERFACE HeirarchicalBasis_Triangle_
!----------------------------------------------------------------------------
! LagrangeEvalAll_Triangle
@@ -1178,14 +1211,8 @@ END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1
! summary: Evaluate all Lagrange polynomial of order n at single points
INTERFACE LagrangeEvalAll_Triangle
- MODULE FUNCTION LagrangeEvalAll_Triangle1( &
- & order, &
- & x, &
- & xij, &
- & refTriangle, &
- & coeff, &
- & firstCall, &
- & basisType) RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll_Triangle1(order, x, xij, refTriangle, &
+ coeff, firstCall, basisType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(2)
@@ -1211,6 +1238,42 @@ MODULE FUNCTION LagrangeEvalAll_Triangle1( &
END FUNCTION LagrangeEvalAll_Triangle1
END INTERFACE LagrangeEvalAll_Triangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Triangle_
+ MODULE SUBROUTINE LagrangeEvalAll_Triangle1_(order, x, xij, ans, tsize, &
+ refTriangle, coeff, firstCall, basisType)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(2)
+ !! point of evaluation
+ !! x(1) is x coord
+ !! x(2) is y coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !!
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Total size written in ans
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Jacobi=Dubiner
+ !! Heirarchical
+ END SUBROUTINE LagrangeEvalAll_Triangle1_
+END INTERFACE LagrangeEvalAll_Triangle_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Triangle
!----------------------------------------------------------------------------
@@ -1220,15 +1283,8 @@ END FUNCTION LagrangeEvalAll_Triangle1
! summary: Evaluate all Lagrange polynomials of order n at several points
INTERFACE LagrangeEvalAll_Triangle
- MODULE FUNCTION LagrangeEvalAll_Triangle2( &
- & order, &
- & x, &
- & xij, &
- & refTriangle, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, beta, lambda) RESULT(ans)
+ MODULE FUNCTION LagrangeEvalAll_Triangle2(order, x, xij, refTriangle, &
+ coeff, firstCall, basisType, alpha, beta, lambda) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of Lagrange polynomials
REAL(DFP), INTENT(IN) :: x(:, :)
@@ -1257,6 +1313,61 @@ MODULE FUNCTION LagrangeEvalAll_Triangle2( &
END FUNCTION LagrangeEvalAll_Triangle2
END INTERFACE LagrangeEvalAll_Triangle
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Triangle_@LagrnageBasisMethods
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Triangle_
+ MODULE SUBROUTINE LagrangeEvalAll_Triangle2_(order, x, xij, ans, nrow, &
+ ncol, refTriangle, coeff, firstCall, basisType, alpha, beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! Point of evaluation
+ !! x(1, :) is x coord
+ !! x(2, :) is y coord
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! Interpolation points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x, 2), SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of rows and columns written to ans
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle
+ !! Biunit
+ !! Unit
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomials *Default
+ !! Jacobi=Dubiner
+ !! Heirarchical
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha, beta, lambda
+ END SUBROUTINE LagrangeEvalAll_Triangle2_
+END INTERFACE LagrangeEvalAll_Triangle_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE FUNCTION QuadratureNumber_Triangle(order, quadType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ INTEGER(I4B) :: ans
+ !! Quadrature points
+ END FUNCTION QuadratureNumber_Triangle
+END INTERFACE
+
!----------------------------------------------------------------------------
! QuadraturePoints_Triangle
!----------------------------------------------------------------------------
@@ -1275,8 +1386,7 @@ MODULE FUNCTION QuadraturePoint_Triangle1(order, quadType, refTriangle, &
!! currently this variable is not used
CHARACTER(*), INTENT(IN) :: refTriangle
!! Reference triangle
- !! Biunit
- !! Unit
+ !! Biunit ! Unit
!! If xij is present,then this parameter is not used
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! nodal coordinates of triangle.
@@ -1287,6 +1397,32 @@ MODULE FUNCTION QuadraturePoint_Triangle1(order, quadType, refTriangle, &
END FUNCTION QuadraturePoint_Triangle1
END INTERFACE QuadraturePoint_Triangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Triangle_
+ MODULE SUBROUTINE QuadraturePoint_Triangle1_(order, quadType, refTriangle, &
+ xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle
+ !! Biunit ! Unit
+ !! If xij is present,then this parameter is not used
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij can be 2 or 3.
+ !! The number of columns in xij should be 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE QuadraturePoint_Triangle1_
+END INTERFACE QuadraturePoint_Triangle_
+
!----------------------------------------------------------------------------
! QuadraturePoints_Triangle
!----------------------------------------------------------------------------
@@ -1308,8 +1444,7 @@ MODULE FUNCTION QuadraturePoint_Triangle2(nips, quadType, refTriangle, &
!! currently this variable is not used
CHARACTER(*), INTENT(IN) :: refTriangle
!! Reference triangle
- !! Biunit
- !! Unit
+ !! Biunit ! Unit
REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
!! nodal coordinates of triangle.
!! The number of rows in xij can be 2 or 3.
@@ -1319,6 +1454,34 @@ MODULE FUNCTION QuadraturePoint_Triangle2(nips, quadType, refTriangle, &
END FUNCTION QuadraturePoint_Triangle2
END INTERFACE QuadraturePoint_Triangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE QuadraturePoint_Triangle_
+ MODULE SUBROUTINE QuadraturePoint_Triangle2_(nips, quadType, refTriangle, &
+ xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! nips(1) .LE. 79, then we call
+ !! economical quadrature rules.
+ !! Otherwise, this routine will retport
+ !! error
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type,
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle
+ !! Biunit ! Unit
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij can be 2 or 3.
+ !! The number of columns in xij should be 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE QuadraturePoint_Triangle2_
+END INTERFACE QuadraturePoint_Triangle_
+
!----------------------------------------------------------------------------
! TensorQuadraturePoints_Triangle
!----------------------------------------------------------------------------
@@ -1348,6 +1511,31 @@ MODULE FUNCTION TensorQuadraturePoint_Triangle1(order, quadType, &
END FUNCTION TensorQuadraturePoint_Triangle1
END INTERFACE TensorQuadraturePoint_Triangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE TensorQuadraturePoint_Triangle_
+ MODULE SUBROUTINE TensorQuadraturePoint_Triangle1_(order, quadType, &
+ refTriangle, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle ! Biunit ! Unit
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij can be 2 or 3.
+ !! The number of columns in xij should be 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ END SUBROUTINE TensorQuadraturePoint_Triangle1_
+END INTERFACE TensorQuadraturePoint_Triangle_
+
!----------------------------------------------------------------------------
! TensorQuadraturePoints_Triangle
!----------------------------------------------------------------------------
@@ -1380,12 +1568,37 @@ END FUNCTION TensorQuadraturePoint_Triangle2
END INTERFACE TensorQuadraturePoint_Triangle
!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Triangle
+!
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! summary: Evaluate Lagrange polynomials of n at several points
+INTERFACE TensorQuadraturePoint_Triangle_
+ MODULE SUBROUTINE TensorQuadraturePoint_Triangle2_(nipsx, nipsy, quadType, &
+ refTriangle, xij, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: nipsx(1)
+ !! number of integration points in x direction
+ INTEGER(I4B), INTENT(IN) :: nipsy(1)
+ !! number of integration points in y direction
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! quadrature point type
+ !! currently this variable is not used
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle
+ !! Biunit
+ !! Unit
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! nodal coordinates of triangle.
+ !! The number of rows in xij can be 2 or 3.
+ !! The number of columns in xij should be 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Quadrature points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ END SUBROUTINE TensorQuadraturePoint_Triangle2_
+END INTERFACE TensorQuadraturePoint_Triangle_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
INTERFACE LagrangeGradientEvalAll_Triangle
MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( &
@@ -1438,6 +1651,57 @@ MODULE FUNCTION LagrangeGradientEvalAll_Triangle1( &
END FUNCTION LagrangeGradientEvalAll_Triangle1
END INTERFACE LagrangeGradientEvalAll_Triangle
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Triangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate Lagrange polynomials of n at several points
+
+INTERFACE LagrangeGradientEvalAll_Triangle_
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Triangle1_(order, x, xij, ans, &
+ dim1, dim2, dim3, refTriangle, coeff, firstCall, basisType, alpha, &
+ beta, lambda)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of Lagrange polynomials
+ REAL(DFP), INTENT(IN) :: x(:, :)
+ !! point of evaluation in xij format
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ !! xij should be present when firstCall is true.
+ !! It is used for computing the coeff
+ !! If coeff is absent then xij should be present
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! ans(SIZE(x, 2), SIZE(xij, 2), 2)
+ !! Value of gradient of nth order Lagrange polynomials at point x
+ !! The first index denotes point of evaluation
+ !! the second index denotes Lagrange polynomial number
+ !! The third index denotes the spatial dimension in which gradient is
+ !! computed
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! SIZE(x, 2), SIZE(xij, 2), 2
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle
+ !! Biunit
+ !! Unit
+ REAL(DFP), OPTIONAL, INTENT(INOUT) :: coeff(:, :)
+ !! coefficient of Lagrange polynomials
+ LOGICAL(LGT), OPTIONAL :: firstCall
+ !! If firstCall is true, then coeff will be made
+ !! If firstCall is False, then coeff will be used
+ !! Default value of firstCall is True
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! Monomial ! Jacobi ! Legendre ! Chebyshev ! Lobatto ! UnscaledLobatto
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi polynomial parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ END SUBROUTINE LagrangeGradientEvalAll_Triangle1_
+END INTERFACE LagrangeGradientEvalAll_Triangle_
+
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Triangle
!----------------------------------------------------------------------------
@@ -1447,8 +1711,8 @@ END FUNCTION LagrangeGradientEvalAll_Triangle1
! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
INTERFACE HeirarchicalBasisGradient_Triangle
- MODULE FUNCTION HeirarchicalBasisGradient_Triangle1(order, pe1, pe2, pe3,&
- & xij, refTriangle) RESULT(ans)
+ MODULE FUNCTION HeirarchicalBasisGradient_Triangle1(order, pe1, pe2, pe3, &
+ xij, refTriangle) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! Order of approximation inside the triangle (i.e., cell)
!! it should be greater than 2 for cell bubble to exist
@@ -1483,8 +1747,8 @@ END FUNCTION HeirarchicalBasisGradient_Triangle1
! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
INTERFACE HeirarchicalBasisGradient_Triangle_
- MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, pe3,&
- & xij, refTriangle, ans, tsize1, tsize2, tsize3)
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, &
+ pe3, xij, refTriangle, ans, tsize1, tsize2, tsize3)
INTEGER(I4B), INTENT(IN) :: order
!! Order of approximation inside the triangle (i.e., cell)
!! it should be greater than 2 for cell bubble to exist
@@ -1505,13 +1769,56 @@ MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle1_(order, pe1, pe2, pe3,&
!! UNIT: in this case xij is in unit Triangle.
!! BIUNIT: in this case xij is in biunit triangle.
REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
- !! ans( &
- !! & SIZE(xij, 2), &
- !! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 2)
+ !! tsize1 = SIZE(xij, 2)
+ !! tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
+ !! tsize3 = 2
INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3
END SUBROUTINE HeirarchicalBasisGradient_Triangle1_
END INTERFACE HeirarchicalBasisGradient_Triangle_
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE HeirarchicalBasisGradient_Triangle_
+ MODULE SUBROUTINE HeirarchicalBasisGradient_Triangle2_(order, pe1, pe2, &
+ pe3, xij, edgeOrient1, edgeOrient2, edgeOrient3, faceOrient, &
+ refTriangle, ans, tsize1, tsize2, tsize3)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of approximation inside the triangle (i.e., cell)
+ !! it should be greater than 2 for cell bubble to exist
+ INTEGER(I4B), INTENT(IN) :: pe1
+ !! Order of interpolation on edge e1
+ !! It should be greater than 1 for edge bubble to exists
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! Order of interpolation on edge e2
+ !! It should be greater than 1 for edge bubble to exists
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! Order of interpolation on edge e3
+ !! It should be greater than 1 for edge bubble to exists
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! Points of evaluation in xij format
+ INTEGER(I4B), INTENT(IN) :: edgeOrient1
+ !! edge orientation, 1 or -1
+ INTEGER(I4B), INTENT(IN) :: edgeOrient2
+ !! edge orientation, 1 or -1
+ INTEGER(I4B), INTENT(IN) :: edgeOrient3
+ !! edge orientation, 1 or -1
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:)
+ !! orientation of face
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! This parameter denotes the type of reference triangle.
+ !! It can take following values:
+ !! UNIT: in this case xij is in unit Triangle.
+ !! BIUNIT: in this case xij is in biunit triangle.
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! tsize1 = SIZE(xij, 2)
+ !! tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
+ !! tsize3 = 2
+ INTEGER(I4B), INTENT(OUT) :: tsize1, tsize2, tsize3
+ END SUBROUTINE HeirarchicalBasisGradient_Triangle2_
+END INTERFACE HeirarchicalBasisGradient_Triangle_
+
!----------------------------------------------------------------------------
! OrthogonalBasisGradient_Triangle
!----------------------------------------------------------------------------
@@ -1550,10 +1857,8 @@ END SUBROUTINE HeirarchicalBasisGradient_Triangle1_
!$$
INTERFACE OrthogonalBasisGradient_Triangle
- MODULE FUNCTION OrthogonalBasisGradient_Triangle1( &
- & order, &
- & xij, &
- & refTriangle) RESULT(ans)
+ MODULE FUNCTION OrthogonalBasisGradient_Triangle1(order, xij, refTriangle) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
!! order of polynomial space
REAL(DFP), INTENT(IN) :: xij(:, :)
diff --git a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90 b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90
index b60a68710..410ea9655 100644
--- a/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90
+++ b/src/modules/Polynomial/src/UltrasphericalPolynomialUtility.F90
@@ -22,9 +22,12 @@
!{!pages/UltrasphericalPolynomialUtility.md!}
MODULE UltrasphericalPolynomialUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+
USE BaseType, ONLY: iface_1DFunction
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: UltrasphericalAlpha
PUBLIC :: UltrasphericalBeta
@@ -52,6 +55,7 @@ MODULE UltrasphericalPolynomialUtility
PUBLIC :: UltrasphericalEvalSum
PUBLIC :: UltrasphericalGradientEvalSum
PUBLIC :: UltrasphericalTransform
+PUBLIC :: UltrasphericalTransform_
PUBLIC :: UltrasphericalInvTransform
PUBLIC :: UltrasphericalGradientCoeff
PUBLIC :: UltrasphericalDMatrix
@@ -456,7 +460,7 @@ END SUBROUTINE UltrasphericalQuadrature
! the point
! X.
-INTERFACE
+INTERFACE UltrasphericalEval
MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -466,10 +470,6 @@ MODULE PURE FUNCTION UltrasphericalEval1(n, lambda, x) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -493,7 +493,7 @@ END FUNCTION UltrasphericalEval1
! the point
! X.
-INTERFACE
+INTERFACE UltrasphericalEval
MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -503,10 +503,6 @@ MODULE PURE FUNCTION UltrasphericalEval2(n, lambda, x) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -762,7 +758,7 @@ END SUBROUTINE UltrasphericalGradientEvalAll2_
!
! Evaluate gradient of Ultraspherical polynomial of order upto n.
-INTERFACE
+INTERFACE UltrasphericalGradientEval
MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -771,11 +767,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEval1(n, lambda, x) RESULT(ans)
REAL(DFP), INTENT(IN) :: x
REAL(DFP) :: ans
END FUNCTION UltrasphericalGradientEval1
-END INTERFACE
-!!
-
-INTERFACE UltrasphericalGradientEval
- MODULE PROCEDURE UltrasphericalGradientEval1
END INTERFACE UltrasphericalGradientEval
!----------------------------------------------------------------------------
@@ -790,7 +781,7 @@ END FUNCTION UltrasphericalGradientEval1
!
! Evaluate gradient of Ultraspherical polynomial of order upto n.
-INTERFACE
+INTERFACE UltrasphericalGradientEval
MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -799,10 +790,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEval2(n, lambda, x) RESULT(ans)
REAL(DFP), INTENT(IN) :: x(:)
REAL(DFP) :: ans(1:SIZE(x))
END FUNCTION UltrasphericalGradientEval2
-END INTERFACE
-
-INTERFACE UltrasphericalGradientEval
- MODULE PROCEDURE UltrasphericalGradientEval2
END INTERFACE UltrasphericalGradientEval
!----------------------------------------------------------------------------
@@ -813,7 +800,7 @@ END FUNCTION UltrasphericalGradientEval2
! date: 6 Sept 2022
! summary: Evaluate finite sum of Ultraspherical polynomials at point x
-INTERFACE
+INTERFACE UltrasphericalEvalSum
MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -827,10 +814,6 @@ MODULE PURE FUNCTION UltrasphericalEvalSum1(n, lambda, x, coeff) &
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
!----------------------------------------------------------------------------
@@ -841,7 +824,7 @@ END FUNCTION UltrasphericalEvalSum1
! date: 6 Sept 2022
! summary: Evaluate finite sum of Ultraspherical polynomials at several x
-INTERFACE
+INTERFACE UltrasphericalEvalSum
MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of polynomial
@@ -854,10 +837,6 @@ MODULE PURE FUNCTION UltrasphericalEvalSum2(n, lambda, x, coeff) RESULT(ans)
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
!----------------------------------------------------------------------------
@@ -869,7 +848,7 @@ END FUNCTION UltrasphericalEvalSum2
! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials
! at point x
-INTERFACE
+INTERFACE UltrasphericalGradientEvalSum
MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, &
& coeff) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -883,10 +862,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum1(n, lambda, x, &
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
!----------------------------------------------------------------------------
@@ -898,7 +873,7 @@ END FUNCTION UltrasphericalGradientEvalSum1
! summary: Evaluate the gradient of finite sum of Ultraspherical polynomials
! at several x
-INTERFACE
+INTERFACE UltrasphericalGradientEvalSum
MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) &
& RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -912,10 +887,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum2(n, lambda, x, coeff) &
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
!----------------------------------------------------------------------------
@@ -927,7 +898,7 @@ END FUNCTION UltrasphericalGradientEvalSum2
! summary: Evaluate the kth derivative of finite sum of Ultraspherical
! polynomials at point x
-INTERFACE
+INTERFACE UltrasphericalGradientEvalSum
MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, &
& coeff, k) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -943,10 +914,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum3(n, lambda, x, &
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
!----------------------------------------------------------------------------
@@ -958,7 +925,7 @@ END FUNCTION UltrasphericalGradientEvalSum3
! summary: Evaluate the kth gradient of finite sum of Ultraspherical
! polynomials at several x
-INTERFACE
+INTERFACE UltrasphericalGradientEvalSum
MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, &
& coeff, k) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -974,10 +941,6 @@ MODULE PURE FUNCTION UltrasphericalGradientEvalSum4(n, lambda, x, &
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
!----------------------------------------------------------------------------
@@ -988,7 +951,7 @@ END FUNCTION UltrasphericalGradientEvalSum4
! date: 13 Oct 2022
! summary: Discrete Ultraspherical Transform
-INTERFACE
+INTERFACE UltrasphericalTransform
MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, &
& quadType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
@@ -1007,10 +970,6 @@ MODULE PURE FUNCTION UltrasphericalTransform1(n, lambda, coeff, x, w, &
REAL(DFP) :: ans(0:n)
!! modal values or coefficients
END FUNCTION UltrasphericalTransform1
-END INTERFACE
-
-INTERFACE UltrasphericalTransform
- MODULE PROCEDURE UltrasphericalTransform1
END INTERFACE UltrasphericalTransform
!----------------------------------------------------------------------------
@@ -1018,33 +977,66 @@ END FUNCTION UltrasphericalTransform1
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 13 Oct 2022
-! summary: Columnwise Discrete Ultraspherical Transform
+! date: 2024-08-19
+! summary: Ultraspherical transform
-INTERFACE
- MODULE PURE FUNCTION UltrasphericalTransform2(n, lambda, coeff, x, w, &
- & quadType) RESULT(ans)
+INTERFACE UltrasphericalTransform_
+ MODULE PURE SUBROUTINE UltrasphericalTransform1_(n, lambda, coeff, x, w, &
+ quadType, ans, tsize)
INTEGER(I4B), INTENT(IN) :: n
- !! order of polynomial
+ !! order of jacobi polynomial
REAL(DFP), INTENT(IN) :: lambda
!! $\lambda > -0.5, \lambda \ne 0.0$
- REAL(DFP), INTENT(IN) :: coeff(0:, 1:)
+ REAL(DFP), INTENT(IN) :: coeff(0:)
!! nodal value (at quad points)
- REAL(DFP), INTENT(IN) :: x(0:n)
+ REAL(DFP), INTENT(IN) :: x(0:)
!! quadrature points
- REAL(DFP), INTENT(IN) :: w(0:n)
+ REAL(DFP), INTENT(IN) :: w(0:)
!! 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
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! ans(0:n)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! size of ans
+ !! n + 1
+ END SUBROUTINE UltrasphericalTransform1_
+END INTERFACE UltrasphericalTransform_
-INTERFACE UltrasphericalTransform
- MODULE PROCEDURE UltrasphericalTransform2
-END INTERFACE UltrasphericalTransform
+!----------------------------------------------------------------------------
+! UltrasphericalTransform
+!----------------------------------------------------------------------------
+
+INTERFACE UltrasphericalTransform_
+ MODULE PURE SUBROUTINE UltrasphericalTransform4_(n, lambda, coeff, PP, w, &
+ quadType, ans, tsize)
+ 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:)
+ !! nodal value (at quad points)
+ !! size is number of quadrature points
+ REAL(DFP), INTENT(IN) :: PP(0:, 0:)
+ !! quadrature points
+ !! number of rows is number of quadrature points
+ !! number of columns is n+1
+ REAL(DFP), INTENT(IN) :: w(0:)
+ !! weights
+ !! size of number of quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
+ !! GaussRadauRight
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! ans(0:n)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! size of ans
+ !! n + 1
+ END SUBROUTINE UltrasphericalTransform4_
+END INTERFACE UltrasphericalTransform_
!----------------------------------------------------------------------------
! UltrasphericalTransform
@@ -1074,9 +1066,9 @@ END FUNCTION UltrasphericalTransform2
! `UltrasphericalQuadrature` which is not pure due to Lapack call.
!@endnote
-INTERFACE
- MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) &
- & RESULT(ans)
+INTERFACE UltrasphericalTransform
+ MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType, x1, x2) &
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of jacobi polynomial
REAL(DFP), INTENT(IN) :: lambda
@@ -1086,15 +1078,37 @@ MODULE FUNCTION UltrasphericalTransform3(n, lambda, f, quadType) &
INTEGER(I4B), INTENT(IN) :: quadType
!! Quadrature type, Gauss, GaussLobatto, GaussRadau, GaussRadauLeft
!! GaussRadauRight
+ REAL(DFP), INTENT(IN) :: x1, x2
REAL(DFP) :: ans(0:n)
!! modal values or coefficients
END FUNCTION UltrasphericalTransform3
-END INTERFACE
-
-INTERFACE UltrasphericalTransform
- MODULE PROCEDURE UltrasphericalTransform3
END INTERFACE UltrasphericalTransform
+!----------------------------------------------------------------------------
+! UltrasphericalTransform
+!----------------------------------------------------------------------------
+
+INTERFACE UltrasphericalTransform_
+ MODULE SUBROUTINE UltrasphericalTransform3_(n, lambda, f, quadType, &
+ x1, x2, ans, tsize)
+ 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), INTENT(IN) :: x1, x2
+ !! domain of function f
+ REAL(DFP), INTENT(INOUT) :: ans(0:)
+ !! ans(0:n)
+ !! modal values or coefficients
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE UltrasphericalTransform3_
+END INTERFACE UltrasphericalTransform_
+
!----------------------------------------------------------------------------
! UltrasphericalInvTransform
!----------------------------------------------------------------------------
@@ -1105,7 +1119,7 @@ END FUNCTION UltrasphericalTransform3
INTERFACE
MODULE PURE FUNCTION UltrasphericalInvTransform1(n, lambda, coeff, x) &
- & RESULT(ans)
+ RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
!! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: lambda
diff --git a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90 b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90
index d766d0344..555c42fb9 100644
--- a/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90
+++ b/src/modules/Polynomial/src/UnscaledLobattoPolynomialUtility.F90
@@ -29,9 +29,11 @@ MODULE UnscaledLobattoPolynomialUtility
PUBLIC :: UnscaledLobattoZeros
PUBLIC :: UnscaledLobattoEval
PUBLIC :: UnscaledLobattoEvalAll
+PUBLIC :: UnscaledLobattoEvalAll_
PUBLIC :: UnscaledLobattoMonomialExpansionAll
PUBLIC :: UnscaledLobattoMonomialExpansion
PUBLIC :: UnscaledLobattoGradientEvalAll
+PUBLIC :: UnscaledLobattoGradientEvalAll_
PUBLIC :: UnscaledLobattoGradientEval
PUBLIC :: UnscaledLobattoMassMatrix
PUBLIC :: UnscaledLobattoStiffnessMatrix
@@ -92,7 +94,7 @@ END FUNCTION UnscaledLobattoZeros
!> author: Vikas Sharma, Ph. D.
! date: 6 Sept 2022
-! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n at several points
+! summary: Evaluate UnscaledLobatto polynomials from order = 0 to n
!
!# Introduction
!
@@ -105,17 +107,13 @@ END FUNCTION UnscaledLobattoZeros
!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto
! polynomials at the point X.
-INTERFACE
+INTERFACE UnscaledLobattoEval
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
!----------------------------------------------------------------------------
@@ -138,17 +136,13 @@ END FUNCTION UnscaledLobattoEval1
!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at
! the point X.
-INTERFACE
+INTERFACE UnscaledLobattoEval
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
!----------------------------------------------------------------------------
@@ -171,7 +165,7 @@ END FUNCTION UnscaledLobattoEval2
!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at
! the point X.
-INTERFACE
+INTERFACE UnscaledLobattoEvalAll
MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
REAL(DFP), INTENT(IN) :: x
@@ -179,12 +173,24 @@ MODULE PURE FUNCTION UnscaledLobattoEvalAll1(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! UnscaledLobattoEvalAll_
+!----------------------------------------------------------------------------
+
+INTERFACE UnscaledLobattoEvalAll_
+ MODULE PURE SUBROUTINE UnscaledLobattoEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! ans(n + 1)
+ !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE UnscaledLobattoEvalAll1_
+END INTERFACE UnscaledLobattoEvalAll_
+
!----------------------------------------------------------------------------
! UnscaledLobattoEvalAll
!----------------------------------------------------------------------------
@@ -205,7 +211,8 @@ END FUNCTION UnscaledLobattoEvalAll1
!- ans(M,1:N+1), the values of the first N+1 UnscaledLobatto polynomials at
! the point X.
-INTERFACE
+INTERFACE UnscaledLobattoEvalAll
+
MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: n
REAL(DFP), INTENT(IN) :: x(:)
@@ -213,12 +220,25 @@ MODULE PURE FUNCTION UnscaledLobattoEvalAll2(n, x) RESULT(ans)
!! 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
+!----------------------------------------------------------------------------
+! UnscaledLobattoEvalAll_
+!----------------------------------------------------------------------------
+
+INTERFACE UnscaledLobattoEvalAll_
+
+ MODULE PURE SUBROUTINE UnscaledLobattoEvalAll2_(n, x, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), n + 1)
+ !! Evaluate UnscaledLobatto polynomial of order = 0 to n (total n+1)
+ !! at point x
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE UnscaledLobattoEvalAll2_
+END INTERFACE UnscaledLobattoEvalAll_
+
!----------------------------------------------------------------------------
! UnscaledLobattoMonomialExpansionAll
!----------------------------------------------------------------------------
@@ -287,23 +307,32 @@ END FUNCTION UnscaledLobattoMonomialExpansion
!
! Evaluate gradient of UnscaledLobatto polynomial of order upto n.
-INTERFACE
+INTERFACE UnscaledLobattoGradientEvalAll
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
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+INTERFACE UnscaledLobattoGradientEvalAll_
+ MODULE PURE SUBROUTINE UnscaledLobattoGradientEvalAll1_(n, x, ans, tsize)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! ans(1:n + 1)
+ END SUBROUTINE UnscaledLobattoGradientEvalAll1_
+END INTERFACE UnscaledLobattoGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n
@@ -312,23 +341,34 @@ END FUNCTION UnscaledLobattoGradientEvalAll1
!
! Evaluate gradient of UnscaledLobatto polynomial of order upto n.
-INTERFACE
+INTERFACE UnscaledLobattoGradientEvalAll
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
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+INTERFACE UnscaledLobattoGradientEvalAll_
+ MODULE PURE SUBROUTINE UnscaledLobattoGradientEvalAll2_(n, x, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n
+ REAL(DFP), INTENT(IN) :: x(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x)
+ !! ncol = n + 1
+ END SUBROUTINE UnscaledLobattoGradientEvalAll2_
+END INTERFACE UnscaledLobattoGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 8 Sept 2022
! summary: Evaluate gradient of UnscaledLobatto polynomial of order upto n
@@ -337,18 +377,14 @@ END FUNCTION UnscaledLobattoGradientEvalAll2
!
! Evaluate gradient of UnscaledLobatto polynomial of order upto n.
-INTERFACE
+INTERFACE UnscaledLobattoGradientEval
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
+!!
!----------------------------------------------------------------------------
!
@@ -362,16 +398,12 @@ END FUNCTION UnscaledLobattoGradientEval1
!
! Evaluate gradient of UnscaledLobatto polynomial of order upto n.
-INTERFACE
+INTERFACE UnscaledLobattoGradientEval
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
!----------------------------------------------------------------------------
diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90
index 8ba04ee10..e00778429 100755
--- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90
+++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90
@@ -19,22 +19,30 @@
! summary: This module contains the methods for data type [[QuadraturePoint_]]
MODULE QuadraturePoint_Method
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: QuadraturePoint_, ReferenceElement_
+USE GlobalData, ONLY: DFP, I4B, LGT
USE String_Class, ONLY: String
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: Initiate
PUBLIC :: QuadraturePoint
PUBLIC :: QuadraturePoint_Pointer
PUBLIC :: DEALLOCATE
PUBLIC :: SIZE
-PUBLIC :: GetTotalQuadraturepoints
-PUBLIC :: GetQuadraturepoints
+PUBLIC :: GetTotalQuadraturePoints
+
+PUBLIC :: GetQuadraturePoints
+PUBLIC :: GetQuadraturePoints_
+PUBLIC :: GetQuadratureWeights_
+
PUBLIC :: Outerprod
PUBLIC :: Display
-PUBLIC :: QuadraturePoint_MdEncode
+! PUBLIC :: QuadraturePoint_MdEncode
PUBLIC :: QuadraturePointIdToName
+PUBLIC :: QuadraturePoint_ToChar
PUBLIC :: QuadraturePointNameToId
PUBLIC :: MdEncode
@@ -68,23 +76,57 @@ MODULE FUNCTION QuadraturePointIdToName(name) RESULT(ans)
END FUNCTION QuadraturePointIdToName
END INTERFACE
+!----------------------------------------------------------------------------
+! QuadraturePoint_ToChar@ConstructorMethods
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE FUNCTION QuadraturePoint_ToChar(name) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ TYPE(String) :: ans
+ END FUNCTION QuadraturePoint_ToChar
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! QuadratureNumber@ConstructorMethods
+!----------------------------------------------------------------------------
+
+INTERFACE QuadratureNumber
+ MODULE FUNCTION obj_QuadratureNumber1(topo, order, quadratureType) &
+ RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: topo
+ !! Reference-element
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadratureType
+ !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau
+ !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight
+ INTEGER(I4B) :: ans
+ !! quadrature number
+ !! for quadrangle element ans is number of quadrature points in x and y
+ !! so total number of quadrature points are ans*ans
+ END FUNCTION obj_QuadratureNumber1
+END INTERFACE QuadratureNumber
+
!----------------------------------------------------------------------------
! Initiate@ConstructorMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
INTERFACE Initiate
- MODULE PURE SUBROUTINE quad_initiate1(obj, points)
- CLASS(QuadraturePoint_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_Initiate1(obj, points)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: points(:, :)
!! points contains the quadrature points and weights
!! points( :, ipoint ) contains quadrature points and weights of ipoint
!! quadrature point. The last row contains the weight. The rest of the
!! rows contains the coordinates of quadrature.
- END SUBROUTINE quad_initiate1
+ END SUBROUTINE obj_Initiate1
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -93,11 +135,11 @@ END SUBROUTINE quad_initiate1
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
INTERFACE Initiate
- MODULE PURE SUBROUTINE quad_initiate2(obj, tXi, tpoints)
- CLASS(QuadraturePoint_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_Initiate2(obj, tXi, tpoints)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: tXi
!! Total number of xidimension
!! For line tXi=1
@@ -105,7 +147,7 @@ MODULE PURE SUBROUTINE quad_initiate2(obj, tXi, tpoints)
!! For 3D element tXi=3
INTEGER(I4B), INTENT(IN) :: tpoints
!! Total number quadrature points
- END SUBROUTINE quad_initiate2
+ END SUBROUTINE obj_Initiate2
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -114,11 +156,15 @@ END SUBROUTINE quad_initiate2
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
+!
+!# Introduction
+!
+! We call obj_Initiate5 in this routine
INTERFACE Initiate
- MODULE SUBROUTINE quad_initiate3(obj, refElem, order, quadratureType, &
- & alpha, beta, lambda)
+ MODULE SUBROUTINE obj_Initiate3(obj, refElem, order, quadratureType, &
+ alpha, beta, lambda)
TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
!! Total number of xidimension
CLASS(ReferenceElement_), INTENT(IN) :: refElem
@@ -127,21 +173,18 @@ MODULE SUBROUTINE quad_initiate3(obj, refElem, order, quadratureType, &
!! order of integrand
CHARACTER(*), INTENT(IN) :: quadratureType
!! Type of quadrature points
- !! "GaussLegendre"
- !! "GaussLegendreLobatto"
+ !! "GaussLegendre" ! "GaussLegendreLobatto"
!! "GaussLegendreRadau", "GaussLegendreRadauLeft"
- !! "GaussLegendreRadauRight"
- !! "GaussChebyshev"
- !! "GaussChebyshevLobatto"
- !! "GaussChebyshevRadau", "GaussChebyshevRadauLeft"
- !! "GaussChebyshevRadauRight"
+ !! "GaussLegendreRadauRight" ! "GaussChebyshev"
+ !! "GaussChebyshevLobatto" ! "GaussChebyshevRadau",
+ !! "GaussChebyshevRadauLeft" ! "GaussChebyshevRadauRight"
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical parameter
- END SUBROUTINE quad_initiate3
+ END SUBROUTINE obj_Initiate3
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -150,11 +193,15 @@ END SUBROUTINE quad_initiate3
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
+!
+!# Introduction
+!
+! We call obj_Initiate6 in this routine
INTERFACE Initiate
- MODULE SUBROUTINE quad_initiate4(obj, refElem, nips, quadratureType, &
- & alpha, beta, lambda)
+ MODULE SUBROUTINE obj_Initiate4(obj, refElem, nips, quadratureType, &
+ alpha, beta, lambda)
TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
!! Total number of xidimension
CLASS(ReferenceElement_), INTENT(IN) :: refElem
@@ -169,7 +216,7 @@ MODULE SUBROUTINE quad_initiate4(obj, refElem, nips, quadratureType, &
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical parameter
- END SUBROUTINE quad_initiate4
+ END SUBROUTINE obj_Initiate4
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -181,12 +228,8 @@ END SUBROUTINE quad_initiate4
! summary: This routine constructs the quadrature points
INTERFACE Initiate
- MODULE SUBROUTINE quad_initiate5( &
- & obj, &
- & refElem, &
- & order, &
- & quadratureType, &
- & alpha, beta, lambda)
+ MODULE SUBROUTINE obj_Initiate5(obj, refElem, order, quadratureType, &
+ alpha, beta, lambda)
TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
!! Total number of xidimension
CLASS(ReferenceElement_), INTENT(IN) :: refElem
@@ -194,24 +237,17 @@ MODULE SUBROUTINE quad_initiate5( &
INTEGER(I4B), INTENT(IN) :: order
!! order of integrand
INTEGER(I4B), INTENT(IN) :: quadratureType
- !! Type of quadrature points
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadau
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev
- !! GaussChebyshevLobatto
- !! GaussChebyshevRadau
- !! GaussChebyshevRadauLeft
- !! GaussChebyshevRadauRight
+ !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau
+ !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical parameter
- END SUBROUTINE quad_initiate5
+ END SUBROUTINE obj_Initiate5
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -220,34 +256,22 @@ END SUBROUTINE quad_initiate5
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
INTERFACE Initiate
- MODULE SUBROUTINE quad_initiate6( &
- & obj, &
- & refElem, &
- & nips, &
- & quadratureType, &
- & alpha, &
- & beta, &
- & lambda)
+ MODULE SUBROUTINE obj_Initiate6(obj, refElem, nips, quadratureType, &
+ alpha, beta, lambda)
TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
!! Total number of xidimension
CLASS(ReferenceElement_), INTENT(IN) :: refElem
!! Reference element
INTEGER(I4B), INTENT(IN) :: nips(1)
- !! order of integrand
+ !! number of integration points
INTEGER(I4B), INTENT(IN) :: quadratureType
!! Type of quadrature points
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadau
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev
- !! GaussChebyshevLobatto
- !! GaussChebyshevRadau
- !! GaussChebyshevRadauLeft
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev
+ !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft
!! GaussChebyshevRadauRight
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
!! Jacobi parameter
@@ -255,28 +279,20 @@ MODULE SUBROUTINE quad_initiate6( &
!! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
!! Ultraspherical parameter
- END SUBROUTINE quad_initiate6
+ END SUBROUTINE obj_Initiate6
END INTERFACE Initiate
-
!----------------------------------------------------------------------------
! Initiate@ConstructorMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
INTERFACE Initiate
- MODULE SUBROUTINE quad_initiate7( &
- & obj, &
- & refElem, &
- & p, q, r, &
- & quadratureType1, &
- & quadratureType2, &
- & quadratureType3, &
- & alpha1, beta1, lambda1, &
- & alpha2, beta2, lambda2, &
- & alpha3, beta3, lambda3)
+ MODULE SUBROUTINE obj_Initiate7(obj, refElem, p, q, r, quadratureType1, &
+ quadratureType2, quadratureType3, alpha1, beta1, lambda1, alpha2, &
+ beta2, lambda2, alpha3, beta3, lambda3)
TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
!! Total number of xidimension
CLASS(ReferenceElement_), INTENT(IN) :: refElem
@@ -288,17 +304,10 @@ MODULE SUBROUTINE quad_initiate7( &
INTEGER(I4B), INTENT(IN) :: r
!! order of integrand in z direction
INTEGER(I4B), INTENT(IN) :: quadratureType1
- !! Type of quadrature points
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadau
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev
- !! GaussChebyshevLobatto
- !! GaussChebyshevRadau
- !! GaussChebyshevRadauLeft
- !! GaussChebyshevRadauRight
+ !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau
+ !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight
INTEGER(I4B), INTENT(IN) :: quadratureType2
!! Type of quadrature points
INTEGER(I4B), INTENT(IN) :: quadratureType3
@@ -309,7 +318,7 @@ MODULE SUBROUTINE quad_initiate7( &
!! Jacobi parameter and Ultraspherical parameters
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
!! Jacobi parameter and Ultraspherical parameters
- END SUBROUTINE quad_initiate7
+ END SUBROUTINE obj_Initiate7
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -318,21 +327,12 @@ END SUBROUTINE quad_initiate7
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiates the quadrature points
+! summary: This routine Initiates the quadrature points
INTERFACE Initiate
- MODULE SUBROUTINE quad_initiate8( &
- & obj, &
- & refElem, &
- & nipsx, &
- & nipsy, &
- & nipsz, &
- & quadratureType1, &
- & quadratureType2, &
- & quadratureType3, &
- & alpha1, beta1, lambda1, &
- & alpha2, beta2, lambda2, &
- & alpha3, beta3, lambda3)
+ MODULE SUBROUTINE obj_Initiate8(obj, refElem, nipsx, nipsy, nipsz, &
+ quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, &
+ lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3)
TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
!! Total number of xidimension
CLASS(ReferenceElement_), INTENT(IN) :: refElem
@@ -345,15 +345,9 @@ MODULE SUBROUTINE quad_initiate8( &
!! number of integration points in z direction
INTEGER(I4B), INTENT(IN) :: quadratureType1
!! Type of quadrature points
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussLegendreRadau
- !! GaussLegendreRadauLeft
- !! GaussLegendreRadauRight
- !! GaussChebyshev
- !! GaussChebyshevLobatto
- !! GaussChebyshevRadau
- !! GaussChebyshevRadauLeft
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev
+ !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft
!! GaussChebyshevRadauRight
INTEGER(I4B), INTENT(IN) :: quadratureType2
!! Type of quadrature points
@@ -365,7 +359,154 @@ MODULE SUBROUTINE quad_initiate8( &
!! Jacobi parameter and Ultraspherical parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
!! Jacobi parameter and Ultraspherical parameter
- END SUBROUTINE quad_initiate8
+ END SUBROUTINE obj_Initiate8
+END INTERFACE Initiate
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE Initiate
+ MODULE SUBROUTINE obj_Initiate9(obj, elemType, domainName, order, &
+ quadratureType, alpha, beta, lambda, xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Total number of xidimension
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element name
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain name
+ !! unit or biunit
+ !! Reference-element
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of integrand
+ INTEGER(I4B), INTENT(IN) :: quadratureType
+ !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau
+ !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ END SUBROUTINE obj_Initiate9
+END INTERFACE Initiate
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE Initiate
+ MODULE SUBROUTINE obj_Initiate10(obj, elemType, domainName, nips, &
+ quadratureType, alpha, beta, lambda, xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Total number of xidimension
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element name
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain name
+ !! unit or biunit
+ !! Reference-element
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! order of integrand
+ !! in the case of quadrangle element nips(1) denotes the
+ !! number of quadrature points in the x and y direction
+ !! so the total number of quadrature points are nips(1)*nips(1)
+ INTEGER(I4B), INTENT(IN) :: quadratureType
+ !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau
+ !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: beta
+ !! Jacobi parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
+ !! Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ END SUBROUTINE obj_Initiate10
+END INTERFACE Initiate
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE Initiate
+ MODULE SUBROUTINE obj_Initiate11(obj, elemType, domainName, p, q, r, &
+ quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, &
+ lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Total number of xidimension
+ INTEGER(I4B), INTENT(IN) :: elemtype
+ !! Reference-element
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain name
+ INTEGER(I4B), INTENT(IN) :: p
+ !! order of integrand in x
+ INTEGER(I4B), INTENT(IN) :: q
+ !! order of integrand in y
+ INTEGER(I4B), INTENT(IN) :: r
+ !! order of integrand in z direction
+ INTEGER(I4B), INTENT(IN) :: quadratureType1
+ !! Type of quadrature points ! GaussLegendre ! GaussLegendreLobatto
+ !! GaussLegendreRadau ! GaussLegendreRadauLeft ! GaussLegendreRadauRight
+ !! GaussChebyshev ! GaussChebyshevLobatto ! GaussChebyshevRadau
+ !! GaussChebyshevRadauLeft ! GaussChebyshevRadauRight
+ INTEGER(I4B), INTENT(IN) :: quadratureType2
+ !! Type of quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadratureType3
+ !! Type of quadrature points
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
+ !! Jacobi parameter and Ultraspherical parameters
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2
+ !! Jacobi parameter and Ultraspherical parameters
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
+ !! Jacobi parameter and Ultraspherical parameters
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ END SUBROUTINE obj_Initiate11
+END INTERFACE Initiate
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE Initiate
+ MODULE SUBROUTINE obj_Initiate12(obj, elemType, domainName, nipsx, nipsy, &
+ nipsz, quadratureType1, quadratureType2, quadratureType3, alpha1, beta1, &
+ lambda1, alpha2, beta2, lambda2, alpha3, beta3, lambda3, xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Total number of xidimension
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain name
+ INTEGER(I4B), INTENT(IN) :: nipsx(1)
+ !! number of integration points in x direction
+ INTEGER(I4B), INTENT(IN) :: nipsy(1)
+ !! number of integration points in y direction
+ INTEGER(I4B), INTENT(IN) :: nipsz(1)
+ !! number of integration points in z direction
+ INTEGER(I4B), INTENT(IN) :: quadratureType1
+ !! Type of quadrature points
+ !! GaussLegendre ! GaussLegendreLobatto ! GaussLegendreRadau
+ !! GaussLegendreRadauLeft ! GaussLegendreRadauRight ! GaussChebyshev
+ !! GaussChebyshevLobatto ! GaussChebyshevRadau ! GaussChebyshevRadauLeft
+ !! GaussChebyshevRadauRight
+ INTEGER(I4B), INTENT(IN) :: quadratureType2
+ !! Type of quadrature points
+ INTEGER(I4B), INTENT(IN) :: quadratureType3
+ !! Type of quadrature points
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha1, beta1, lambda1
+ !! Jacobi parameter and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2, beta2, lambda2
+ !! Jacobi parameter and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: alpha3, beta3, lambda3
+ !! Jacobi parameter and Ultraspherical parameter
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! coordinates of reference element
+ END SUBROUTINE obj_Initiate12
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -374,7 +515,7 @@ END SUBROUTINE quad_initiate8
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2021
-! summary: This routine initiate an instance of quadrature points
+! summary: This routine Initiate an instance of quadrature points
INTERFACE QuadraturePoint
MODULE PURE FUNCTION quad_Constructor1(points) RESULT(obj)
@@ -393,7 +534,7 @@ END FUNCTION quad_Constructor1
INTERFACE QuadraturePoint_Pointer
MODULE PURE FUNCTION quad_Constructor_1(points) RESULT(obj)
- CLASS(QuadraturePoint_), POINTER :: obj
+ TYPE(QuadraturePoint_), POINTER :: obj
REAL(DFP), INTENT(IN) :: points(:, :)
END FUNCTION quad_Constructor_1
END INTERFACE QuadraturePoint_Pointer
@@ -408,7 +549,7 @@ END FUNCTION quad_Constructor_1
INTERFACE DEALLOCATE
MODULE PURE SUBROUTINE quad_Deallocate(obj)
- CLASS(QuadraturePoint_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
END SUBROUTINE quad_Deallocate
END INTERFACE DEALLOCATE
@@ -421,11 +562,11 @@ END SUBROUTINE quad_Deallocate
! summary: This routine returns the size of obj%points,
INTERFACE SIZE
- MODULE PURE FUNCTION quad_Size(obj, dims) RESULT(ans)
- CLASS(QuadraturePoint_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Size(obj, dims) RESULT(ans)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: dims
INTEGER(I4B) :: ans
- END FUNCTION quad_Size
+ END FUNCTION obj_Size
END INTERFACE SIZE
!----------------------------------------------------------------------------
@@ -437,11 +578,10 @@ END FUNCTION quad_Size
! summary: This routine returns total number of quadrature points
INTERFACE GetTotalQuadraturepoints
- MODULE PURE FUNCTION quad_getTotalQuadraturepoints(obj, dims) RESULT(ans)
- CLASS(QuadraturePoint_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN) :: dims
+ MODULE PURE FUNCTION obj_GetTotalQuadraturePoints(obj) RESULT(ans)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
INTEGER(I4B) :: ans
- END FUNCTION quad_getTotalQuadraturepoints
+ END FUNCTION obj_GetTotalQuadraturePoints
END INTERFACE GetTotalQuadraturepoints
!----------------------------------------------------------------------------
@@ -452,21 +592,17 @@ END FUNCTION quad_getTotalQuadraturepoints
! date: 23 July 2021
! summary: This routine returns quadrature points
-INTERFACE
- MODULE PURE SUBROUTINE quad_GetQuadraturepoints1(obj, points, weights, num)
- CLASS(QuadraturePoint_), INTENT(IN) :: obj
+INTERFACE GetQuadraturePoints
+ MODULE PURE SUBROUTINE obj_GetQuadraturePoints1(obj, points, weights, num)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
REAL(DFP), INTENT(INOUT) :: points(3)
!! [xi, eta, zeta]
REAL(DFP), INTENT(INOUT) :: weights
!! weights
INTEGER(I4B), INTENT(IN) :: num
!! quadrature number
- END SUBROUTINE quad_GetQuadraturepoints1
-END INTERFACE
-
-INTERFACE GetQuadraturepoints
- MODULE PROCEDURE quad_GetQuadraturepoints1
-END INTERFACE
+ END SUBROUTINE obj_GetQuadraturePoints1
+END INTERFACE GetQuadraturePoints
!----------------------------------------------------------------------------
! GetQuadraturePoint@GetMethods
@@ -476,19 +612,55 @@ END SUBROUTINE quad_GetQuadraturepoints1
! date: 23 July 2021
! summary: This routine returns total number of quadrature points
-INTERFACE
- MODULE PURE SUBROUTINE quad_GetQuadraturepoints2(obj, points, weights)
- CLASS(QuadraturePoint_), INTENT(IN) :: obj
+INTERFACE GetQuadraturePoints
+ MODULE PURE SUBROUTINE obj_GetQuadraturePoints2(obj, points, weights)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: points(:, :)
!! Point( :, j ) = [xi, eta, zeta] of jth quadrature point
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: weights(:)
!! Weight(j) weight of jth quadrature point
- END SUBROUTINE quad_GetQuadraturepoints2
-END INTERFACE
+ END SUBROUTINE obj_GetQuadraturePoints2
+END INTERFACE GetQuadraturePoints
-INTERFACE GetQuadraturepoints
- MODULE PROCEDURE quad_GetQuadraturepoints2
-END INTERFACE
+!----------------------------------------------------------------------------
+! GetQuadraturePoint@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-07
+! summary: This routine returns total number of quadrature points
+
+INTERFACE GetQuadraturePoints_
+ MODULE PURE SUBROUTINE obj_GetQuadraturePoints1_(obj, points, weights, &
+ nrow, ncol)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: points(:, :)
+ !! Point( :, j ) = [xi, eta, zeta] of jth quadrature point
+ REAL(DFP), INTENT(INOUT) :: weights(:)
+ !! Weight(j) weight of jth quadrature point
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns
+ !! ncol is number of columns in points and weights
+ END SUBROUTINE obj_GetQuadraturePoints1_
+END INTERFACE GetQuadraturePoints_
+
+!----------------------------------------------------------------------------
+! GetQuadratureWeight@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-07
+! summary: This routine returns the quadrature weights
+
+INTERFACE GetQuadratureWeights_
+ MODULE PURE SUBROUTINE obj_GetQuadratureWeights1_(obj, weights, tsize)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: weights(:)
+ !! Weight(j) weight of jth quadrature point
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! The number of data written in weights
+ END SUBROUTINE obj_GetQuadratureWeights1_
+END INTERFACE GetQuadratureWeights_
!----------------------------------------------------------------------------
! OuterProd@GetMethods
@@ -499,14 +671,14 @@ END SUBROUTINE quad_GetQuadraturepoints2
! summary: Performs outerproduct of quadrature points
INTERFACE Outerprod
- MODULE PURE FUNCTION quad_Outerprod(obj1, obj2) RESULT(ans)
+ MODULE PURE FUNCTION obj_Outerprod(obj1, obj2) RESULT(ans)
CLASS(QuadraturePoint_), INTENT(IN) :: obj1
!! quadrature points in 1D
CLASS(QuadraturePoint_), INTENT(IN) :: obj2
!! quadrature points in 1D
TYPE(QuadraturePoint_) :: ans
!! quadrature points in 2D
- END FUNCTION quad_Outerprod
+ END FUNCTION obj_Outerprod
END INTERFACE Outerprod
!----------------------------------------------------------------------------
@@ -518,11 +690,11 @@ END FUNCTION quad_Outerprod
! summary: Display the content of quadrature point
INTERFACE Display
- MODULE SUBROUTINE quad_Display(obj, msg, unitno)
+ MODULE SUBROUTINE obj_Display(obj, msg, unitno)
CLASS(QuadraturePoint_), INTENT(IN) :: obj
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitno
- END SUBROUTINE quad_Display
+ END SUBROUTINE obj_Display
END INTERFACE Display
!----------------------------------------------------------------------------
@@ -534,10 +706,10 @@ END SUBROUTINE quad_Display
! summary: Display the content of quadrature point
INTERFACE MdEncode
- MODULE FUNCTION QuadraturePoint_MdEncode(obj) RESULT(ans)
+ MODULE FUNCTION obj_MdEncode(obj) RESULT(ans)
CLASS(QuadraturePoint_), INTENT(IN) :: obj
TYPE(String) :: ans
- END FUNCTION QuadraturePoint_MdEncode
+ END FUNCTION obj_MdEncode
END INTERFACE MdEncode
!----------------------------------------------------------------------------
diff --git a/src/modules/RealMatrix/src/RealMatrix_Method.F90 b/src/modules/RealMatrix/src/RealMatrix_Method.F90
index 79fdc3b4c..66c64f68a 100644
--- a/src/modules/RealMatrix/src/RealMatrix_Method.F90
+++ b/src/modules/RealMatrix/src/RealMatrix_Method.F90
@@ -27,8 +27,8 @@ MODULE RealMatrix_Method
PUBLIC :: Shape
PUBLIC :: Size
-PUBLIC :: TotalDimension
-PUBLIC :: SetTotalDimension
+PUBLIC :: totalDimension
+PUBLIC :: SettotalDimension
PUBLIC :: ALLOCATE
PUBLIC :: DEALLOCATE
PUBLIC :: Initiate
@@ -39,6 +39,7 @@ MODULE RealMatrix_Method
PUBLIC :: SYM
PUBLIC :: SkewSym
PUBLIC :: MakeDiagonalCopies
+PUBLIC :: MakeDiagonalCopies_
PUBLIC :: RANDOM_NUMBER
PUBLIC :: TestMatrix
PUBLIC :: ASSIGNMENT(=)
@@ -108,7 +109,7 @@ END FUNCTION Get_size
END INTERFACE Size
!----------------------------------------------------------------------------
-! TotalDimension@ConstructorMethods
+! totalDimension@ConstructorMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -119,15 +120,15 @@ END FUNCTION Get_size
!
! This function returns the total dimension (or rank) of an array,
-INTERFACE TotalDimension
+INTERFACE totalDimension
MODULE PURE FUNCTION Get_tdimension(obj) RESULT(Ans)
CLASS(RealMatrix_), INTENT(IN) :: obj
INTEGER(I4B) :: Ans
END FUNCTION Get_tdimension
-END INTERFACE TotalDimension
+END INTERFACE totalDimension
!----------------------------------------------------------------------------
-! SetTotalDimension@GetMethods
+! SettotalDimension@GetMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -138,12 +139,12 @@ END FUNCTION Get_tdimension
!
! This subroutine Sets the rank(total dimension) of an array
-INTERFACE SetTotalDimension
+INTERFACE SettotalDimension
MODULE PURE SUBROUTINE Set_tdimension(obj, tDimension)
CLASS(RealMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: tDimension
END SUBROUTINE Set_tdimension
-END INTERFACE SetTotalDimension
+END INTERFACE SettotalDimension
!----------------------------------------------------------------------------
! Allocate@ConstructorMethods
@@ -402,14 +403,14 @@ END FUNCTION realMat_eye1
!
INTERFACE Convert
- MODULE PURE SUBROUTINE realmat_convert_1(From, To, Conversion, &
+ MODULE PURE SUBROUTINE realmat_convert_1(from, to, Conversion, &
& nns, tdof)
- TYPE(RealMatrix_), INTENT(IN) :: From
+ TYPE(RealMatrix_), INTENT(IN) :: from
!! Matrix in one format
- TYPE(RealMatrix_), INTENT(INOUT) :: To
+ TYPE(RealMatrix_), INTENT(INOUT) :: to
!! Matrix in one format
INTEGER(I4B), INTENT(IN) :: Conversion
- !! `Conversion` can be `NodesToDOF` or `DOFToNodes`
+ !! `Conversion` can be `NodestoDOF` or `DOFToNodes`
INTEGER(I4B), INTENT(IN) :: nns, tdof
END SUBROUTINE realmat_convert_1
END INTERFACE Convert
@@ -539,46 +540,72 @@ END FUNCTION SkewSym_array
!
!# Introduction
!
-! This subroutine makes `nCopy` diagonal copies of `Mat` The size of `Mat` on
-! return is nCopy * SIZE( Mat, 1 )
+! This subroutine makes `ncopy` diagonal copies of `Mat` The size of `Mat` on
+! return is ncopy * SIZE( Mat, 1 )
!
!### Usage
!
!```fortran
-! call MakeDiagonalCopies( Mat, nCopy )
+! call MakeDiagonalCopies( Mat, ncopy )
!```
INTERFACE MakeDiagonalCopies
- MODULE PURE SUBROUTINE realmat_make_diag_Copy1(Mat, nCopy)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
- INTEGER(I4B), INTENT(IN) :: nCopy
- END SUBROUTINE realmat_make_diag_Copy1
+ MODULE PURE SUBROUTINE MakeDiagonalCopies1(mat, ncopy)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
+ INTEGER(I4B), INTENT(IN) :: ncopy
+ END SUBROUTINE MakeDiagonalCopies1
END INTERFACE MakeDiagonalCopies
!----------------------------------------------------------------------------
! MakeDiagonalCopies@ConstructorMethods
!----------------------------------------------------------------------------
+INTERFACE MakeDiagonalCopies_
+ MODULE PURE SUBROUTINE MakeDiagonalCopies1_(mat, ncopy, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: mat(:, :)
+ INTEGER(I4B), INTENT(IN) :: ncopy
+ INTEGER(i4b), INTENT(IN) :: nrow, ncol
+ !! nrow and ncol are size of data which is used for making
+ !! diagonal copies
+ END SUBROUTINE MakeDiagonalCopies1_
+END INTERFACE MakeDiagonalCopies_
+
+!----------------------------------------------------------------------------
+! MakeDiagonalCopies@ConstructorMethods
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 6 March 2021
! summary: Make diagonal copies of Matrix
!
-! This subroutine makes `nCopy` diagonal copies of `Mat`
+! This subroutine makes `ncopy` diagonal copies of `Mat`
!
!### Usage
!
!```fortran
-! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy )
+! call MakeDiagonalCopies( from = Mat, to = anotherMat, ncopy = nCopy )
!```
INTERFACE MakeDiagonalCopies
- MODULE PURE SUBROUTINE realmat_make_diag_Copy2(From, To, nCopy)
- REAL(DFP), INTENT(IN) :: From(:, :)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :)
- INTEGER(I4B), INTENT(IN) :: nCopy
- END SUBROUTINE realmat_make_diag_Copy2
+ MODULE PURE SUBROUTINE MakeDiagonalCopies2(from, to, ncopy)
+ REAL(DFP), INTENT(IN) :: from(:, :)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :)
+ INTEGER(I4B), INTENT(IN) :: ncopy
+ END SUBROUTINE MakeDiagonalCopies2
END INTERFACE MakeDiagonalCopies
+!----------------------------------------------------------------------------
+! MakeDiagonalCopies
+!----------------------------------------------------------------------------
+
+INTERFACE MakeDiagonalCopies_
+ MODULE PURE SUBROUTINE MakeDiagonalCopies2_(from, to, ncopy)
+ REAL(DFP), INTENT(IN) :: from(:, :)
+ REAL(DFP), INTENT(INOUT) :: to(:, :)
+ INTEGER(I4B), INTENT(IN) :: ncopy
+ END SUBROUTINE MakeDiagonalCopies2_
+END INTERFACE MakeDiagonalCopies_
+
!----------------------------------------------------------------------------
! MakeDiagonalCopies@ConstructorMethods
!----------------------------------------------------------------------------
@@ -587,22 +614,26 @@ END SUBROUTINE realmat_make_diag_Copy2
! date: 6 March 2021
! summary: Make diagonal copies of [[realmatrix_]]
!
-! This subroutine makes `nCopy` diagonal copies of `Mat`, The size of `Mat`
-! on return is nCopy * SIZE( Mat, 1 )
+! This subroutine makes `ncopy` diagonal copies of `Mat`, The size of `Mat`
+! on return is ncopy * SIZE( Mat, 1 )
!
!### Usage
!
!```fortran
-! call MakeDiagonalCopies( Mat, nCopy )
+! call MakeDiagonalCopies( Mat, ncopy )
!```
INTERFACE MakeDiagonalCopies
- MODULE PURE SUBROUTINE realmat_make_diag_Copy3(Mat, nCopy)
+ MODULE PURE SUBROUTINE MakeDiagonalCopies3(Mat, ncopy)
TYPE(RealMatrix_), INTENT(INOUT) :: Mat
- INTEGER(I4B), INTENT(IN) :: nCopy
- END SUBROUTINE realmat_make_diag_Copy3
+ INTEGER(I4B), INTENT(IN) :: ncopy
+ END SUBROUTINE MakeDiagonalCopies3
END INTERFACE MakeDiagonalCopies
+!----------------------------------------------------------------------------
+! MakeDiagonalCopies
+!----------------------------------------------------------------------------
+
!----------------------------------------------------------------------------
! MakeDiagonalCopies@ConstructorMethods
!----------------------------------------------------------------------------
@@ -613,20 +644,20 @@ END SUBROUTINE realmat_make_diag_Copy3
!
!# Introduction
!
-! This subroutine makes `nCopy` diagonal copies of `Mat`
+! This subroutine makes `ncopy` diagonal copies of `Mat`
!
!### Usage
!
!```fortran
-! call MakeDiagonalCopies( From = Mat, To = anotherMat, nCopy = nCopy )
+! call MakeDiagonalCopies( from = Mat, to = anotherMat, ncopy = nCopy )
!```
INTERFACE MakeDiagonalCopies
- MODULE PURE SUBROUTINE realmat_make_diag_Copy4(From, To, nCopy)
- TYPE(RealMatrix_), INTENT(IN) :: From
- TYPE(RealMatrix_), INTENT(INOUT) :: To
- INTEGER(I4B), INTENT(IN) :: nCopy
- END SUBROUTINE realmat_make_diag_Copy4
+ MODULE PURE SUBROUTINE MakeDiagonalCopies4(from, to, ncopy)
+ TYPE(RealMatrix_), INTENT(IN) :: from
+ TYPE(RealMatrix_), INTENT(INOUT) :: to
+ INTEGER(I4B), INTENT(IN) :: ncopy
+ END SUBROUTINE MakeDiagonalCopies4
END INTERFACE MakeDiagonalCopies
!----------------------------------------------------------------------------
@@ -900,9 +931,9 @@ END FUNCTION realmat_Get8
! fortran array
INTERFACE Copy
- MODULE PURE SUBROUTINE realmat_Copy1(From, To)
- TYPE(RealMatrix_), INTENT(IN) :: From
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :)
+ MODULE PURE SUBROUTINE realmat_Copy1(from, to)
+ TYPE(RealMatrix_), INTENT(IN) :: from
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :)
END SUBROUTINE realmat_Copy1
END INTERFACE Copy
@@ -924,9 +955,9 @@ END SUBROUTINE realmat_Copy1
! RealMatrix object
INTERFACE Copy
- MODULE PURE SUBROUTINE realmat_Copy2(From, To)
- TYPE(RealMatrix_), INTENT(IN) :: From
- TYPE(RealMatrix_), INTENT(INOUT) :: To
+ MODULE PURE SUBROUTINE realmat_Copy2(from, to)
+ TYPE(RealMatrix_), INTENT(IN) :: from
+ TYPE(RealMatrix_), INTENT(INOUT) :: to
END SUBROUTINE realmat_Copy2
END INTERFACE Copy
@@ -952,9 +983,9 @@ END SUBROUTINE realmat_Copy2
! object
INTERFACE Copy
- MODULE PURE SUBROUTINE realmat_Copy3(From, To)
- REAL(DFP), INTENT(IN) :: From(:, :)
- TYPE(RealMatrix_), INTENT(INOUT) :: To
+ MODULE PURE SUBROUTINE realmat_Copy3(from, to)
+ REAL(DFP), INTENT(IN) :: from(:, :)
+ TYPE(RealMatrix_), INTENT(INOUT) :: to
END SUBROUTINE realmat_Copy3
END INTERFACE Copy
@@ -1038,7 +1069,7 @@ MODULE PURE SUBROUTINE realmat_CG_1(mat, rhs, sol, maxIter, &
INTEGER(I4B), OPTIONAL, INTENT(IN) :: convergenceIn
!! convergenceInRes <-- default
!! convergenceInSol
- LOGICAL(LGT), OPTIONAL, INTENT(IN) :: relativeToRHS
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: relativetoRHS
!! FALSE <--- relative converfence is checked with respect to ||res||
!! TRUE Convergence is checked with respect to ||rhs||
INTEGER(I4B), OPTIONAL, INTENT(IN) :: restartAfter
diff --git a/src/modules/RealVector/src/RealVector_AddMethods.F90 b/src/modules/RealVector/src/RealVector_AddMethods.F90
index 9ee9b14dc..e0ea0f749 100644
--- a/src/modules/RealVector/src/RealVector_AddMethods.F90
+++ b/src/modules/RealVector/src/RealVector_AddMethods.F90
@@ -177,7 +177,7 @@ END SUBROUTINE obj_Add7
MODULE SUBROUTINE obj_Add8(obj, dofobj, nodenum, VALUE, &
scale, conversion)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
@@ -197,7 +197,7 @@ END SUBROUTINE obj_Add8
MODULE SUBROUTINE obj_Add9(obj, dofobj, nodenum, VALUE, &
scale)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -216,7 +216,7 @@ END SUBROUTINE obj_Add9
MODULE SUBROUTINE obj_Add10(obj, dofobj, nodenum, VALUE, &
scale, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
@@ -236,7 +236,7 @@ END SUBROUTINE obj_Add10
MODULE SUBROUTINE obj_Add11(obj, dofobj, nodenum, VALUE, &
scale, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -256,7 +256,7 @@ END SUBROUTINE obj_Add11
MODULE SUBROUTINE obj_Add12(obj, dofobj, nodenum, VALUE, &
scale, ivar, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
@@ -277,7 +277,7 @@ END SUBROUTINE obj_Add12
MODULE SUBROUTINE obj_Add13(obj, dofobj, nodenum, VALUE, &
scale, ivar, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -298,7 +298,7 @@ END SUBROUTINE obj_Add13
MODULE SUBROUTINE obj_Add14(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
@@ -320,7 +320,7 @@ END SUBROUTINE obj_Add14
MODULE SUBROUTINE obj_Add15(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -342,7 +342,7 @@ END SUBROUTINE obj_Add15
MODULE SUBROUTINE obj_Add16(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
@@ -364,7 +364,7 @@ END SUBROUTINE obj_Add16
MODULE SUBROUTINE obj_Add17(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -386,7 +386,7 @@ END SUBROUTINE obj_Add17
MODULE SUBROUTINE obj_Add18(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
@@ -408,7 +408,7 @@ END SUBROUTINE obj_Add18
MODULE SUBROUTINE obj_Add19(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -430,7 +430,7 @@ END SUBROUTINE obj_Add19
MODULE SUBROUTINE obj_Add20(obj, dofobj, nodenum, VALUE, &
scale)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -449,7 +449,7 @@ END SUBROUTINE obj_Add20
MODULE SUBROUTINE obj_Add21(obj, dofobj, nodenum, VALUE, &
scale, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -469,7 +469,7 @@ END SUBROUTINE obj_Add21
MODULE SUBROUTINE obj_Add22(obj, dofobj, nodenum, VALUE, &
scale, ivar, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -490,7 +490,7 @@ END SUBROUTINE obj_Add22
MODULE SUBROUTINE obj_Add23(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -512,7 +512,7 @@ END SUBROUTINE obj_Add23
MODULE SUBROUTINE obj_Add24(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
@@ -534,7 +534,7 @@ END SUBROUTINE obj_Add24
MODULE SUBROUTINE obj_Add25(obj, dofobj, nodenum, VALUE, &
scale, ivar, spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
- CLASS(DOF_), INTENT(IN) :: dofobj
+ TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
diff --git a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90 b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90
index 2f9b0479a..67bf4f160 100644
--- a/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90
+++ b/src/modules/StiffnessMatrix/src/StiffnessMatrix_Method.F90
@@ -26,6 +26,7 @@ MODULE StiffnessMatrix_Method
PRIVATE
PUBLIC :: StiffnessMatrix
+PUBLIC :: StiffnessMatrix_
!----------------------------------------------------------------------------
! StiffnessMatrix@StiffnessMatrixMethods
@@ -40,6 +41,23 @@ MODULE PURE FUNCTION obj_StiffnessMatrix1(test, trial, Cijkl) &
END FUNCTION obj_StiffnessMatrix1
END INTERFACE StiffnessMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-02-28
+! summary: subroutine to calculate stiffness matrix
+
+INTERFACE StiffnessMatrix_
+ MODULE PURE SUBROUTINE obj_StiffnessMatrix1_(test, trial, Cijkl, nrow,ncol, ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: test, trial
+ CLASS(FEVariable_), INTENT(IN) :: Cijkl
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ END SUBROUTINE obj_StiffnessMatrix1_
+END INTERFACE StiffnessMatrix_
+
!----------------------------------------------------------------------------
! StiffnessMatrix@StiffnessMatrixMethods
!----------------------------------------------------------------------------
@@ -57,6 +75,21 @@ MODULE PURE FUNCTION obj_StiffnessMatrix2(test, trial, lambda, mu, &
END FUNCTION obj_StiffnessMatrix2
END INTERFACE StiffnessMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE StiffnessMatrix_
+ MODULE PURE SUBROUTINE obj_StiffnessMatrix2_(test, trial, lambda, mu, &
+ isLambdaYoungsModulus, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test, trial
+ CLASS(FEVariable_), INTENT(IN) :: lambda, mu
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isLambdaYoungsModulus
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_StiffnessMatrix2_
+END INTERFACE StiffnessMatrix_
+
!----------------------------------------------------------------------------
! StiffnessMatrix@StiffnessMatrixMethods
!----------------------------------------------------------------------------
@@ -70,6 +103,20 @@ MODULE PURE FUNCTION obj_StiffnessMatrix3(test, trial, lambda, &
END FUNCTION obj_StiffnessMatrix3
END INTERFACE StiffnessMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE StiffnessMatrix_
+ MODULE PURE SUBROUTINE obj_StiffnessMatrix3_(test, trial, lambda, &
+ mu, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test, trial
+ REAL(DFP), INTENT(IN) :: lambda, mu
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_StiffnessMatrix3_
+END INTERFACE StiffnessMatrix_
+
!----------------------------------------------------------------------------
! StiffnessMatrix@StiffnessMatrixMethods
!----------------------------------------------------------------------------
@@ -83,6 +130,20 @@ MODULE PURE FUNCTION obj_StiffnessMatrix4(test, trial, Cijkl) &
END FUNCTION obj_StiffnessMatrix4
END INTERFACE StiffnessMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE StiffnessMatrix_
+ MODULE PURE SUBROUTINE obj_StiffnessMatrix4_(test, trial, Cijkl, ans, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test, trial
+ REAL(DFP), INTENT(IN) :: Cijkl(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_StiffnessMatrix4_
+END INTERFACE StiffnessMatrix_
+
!----------------------------------------------------------------------------
! StiffnessMatrix@StiffnessMatrixMethods
!----------------------------------------------------------------------------
@@ -101,4 +162,19 @@ END FUNCTION obj_StiffnessMatrix5
!
!----------------------------------------------------------------------------
+INTERFACE StiffnessMatrix_
+ MODULE PURE SUBROUTINE obj_StiffnessMatrix5_(test, trial, lambda, mu, &
+ ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test, trial
+ REAL(DFP), INTENT(IN) :: lambda(:)
+ REAL(DFP), INTENT(IN) :: mu(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_StiffnessMatrix5_
+END INTERFACE StiffnessMatrix_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE StiffnessMatrix_Method
diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90
index 9deec4303..2037e78d7 100644
--- a/src/modules/Utility/src/ConvertUtility.F90
+++ b/src/modules/Utility/src/ConvertUtility.F90
@@ -21,6 +21,7 @@ MODULE ConvertUtility
PRIVATE
PUBLIC :: Convert
+PUBLIC :: Convert_
PUBLIC :: ConvertSafe
!----------------------------------------------------------------------------
@@ -126,6 +127,22 @@ MODULE PURE SUBROUTINE convert_2(From, To)
END SUBROUTINE convert_2
END INTERFACE Convert
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: convert without allocation
+
+INTERFACE Convert_
+ MODULE PURE SUBROUTINE convert2_(From, To, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: From(:, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: To(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE convert2_
+END INTERFACE Convert_
+
!----------------------------------------------------------------------------
! Convert@ConvertMethods
!----------------------------------------------------------------------------
@@ -148,4 +165,20 @@ END SUBROUTINE convert_3
!
!----------------------------------------------------------------------------
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: convert without allocation
+
+INTERFACE Convert_
+ MODULE PURE SUBROUTINE convert3_(From, To, dim1, dim2, dim3, dim4)
+ REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: To(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE convert3_
+END INTERFACE Convert_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE ConvertUtility
diff --git a/src/modules/Utility/src/IntegerUtility.F90 b/src/modules/Utility/src/IntegerUtility.F90
index b785680f0..561ce774e 100644
--- a/src/modules/Utility/src/IntegerUtility.F90
+++ b/src/modules/Utility/src/IntegerUtility.F90
@@ -28,9 +28,11 @@ MODULE IntegerUtility
PUBLIC :: Repeat
PUBLIC :: SIZE
PUBLIC :: GetMultiIndices
+PUBLIC :: GetMultiIndices_
PUBLIC :: GetIndex
PUBLIC :: Get
PUBLIC :: GetIntersection
+PUBLIC :: Get1DIndexFortran
!----------------------------------------------------------------------------
! Size@Methods
@@ -69,7 +71,7 @@ END FUNCTION obj_Size2
!> author: Vikas Sharma, Ph. D.
! date: 4 Sept 2022
-! summary: Get Indices
+! summary: Get Indices
INTERFACE GetMultiIndices
MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices1(n, d) RESULT(ans)
@@ -84,7 +86,24 @@ END FUNCTION obj_GetMultiIndices1
!> author: Vikas Sharma, Ph. D.
! date: 4 Sept 2022
-! summary: Get Indices upto order n
+! summary: Get Indices
+
+INTERFACE GetMultiIndices_
+ MODULE RECURSIVE PURE SUBROUTINE obj_GetMultiIndices1_(n, d, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n, d
+ INTEGER(I4B), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_GetMultiIndices1_
+END INTERFACE GetMultiIndices_
+
+!----------------------------------------------------------------------------
+! GetIndices@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 Sept 2022
+! summary: Get Indices upto order n
INTERFACE GetMultiIndices
MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans)
@@ -94,6 +113,24 @@ MODULE RECURSIVE PURE FUNCTION obj_GetMultiIndices2(n, d, upto) RESULT(ans)
END FUNCTION obj_GetMultiIndices2
END INTERFACE GetMultiIndices
+!----------------------------------------------------------------------------
+! GetIndices@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 Sept 2022
+! summary: Get Indices upto order n
+
+INTERFACE GetMultiIndices_
+ MODULE RECURSIVE PURE SUBROUTINE obj_GetMultiIndices2_(n, d, upto, ans, &
+ nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: n, d
+ LOGICAL(LGT), INTENT(IN) :: upto
+ INTEGER(I4B), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_GetMultiIndices2_
+END INTERFACE GetMultiIndices_
+
!----------------------------------------------------------------------------
! Operator(.in.)@IntegerMethods
!----------------------------------------------------------------------------
@@ -466,6 +503,69 @@ MODULE PURE SUBROUTINE GetIntersection4(a, b, c, tsize)
END SUBROUTINE GetIntersection4
END INTERFACE GetIntersection
+!----------------------------------------------------------------------------
+! Get1DIndexFrom2DIndex
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-14
+! summary: Convert (i,j) to ans from Fortran2D array to 1D array
+
+INTERFACE Get1DIndexFortran
+ MODULE PURE FUNCTION Get1DIndexFrom2DFortranIndex(i, j, dim1, dim2) &
+ RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: i
+ INTEGER(I4B), INTENT(IN) :: j
+ INTEGER(I4B), INTENT(IN) :: dim1
+ INTEGER(I4B), INTENT(IN) :: dim2
+ INTEGER(I4B) :: ans
+ END FUNCTION Get1DIndexFrom2DFortranIndex
+END INTERFACE Get1DIndexFortran
+
+!----------------------------------------------------------------------------
+! Get1DIndexFrom2DIndex
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-14
+! summary: Convert (i,j,k) to ans from Fortran3D array to 1D array
+
+INTERFACE Get1DIndexFortran
+ MODULE PURE FUNCTION Get1DIndexFrom3DFortranIndex(i, j, k, dim1, dim2, &
+ dim3) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: i
+ INTEGER(I4B), INTENT(IN) :: j
+ INTEGER(I4B), INTENT(IN) :: k
+ INTEGER(I4B), INTENT(IN) :: dim1
+ INTEGER(I4B), INTENT(IN) :: dim2
+ INTEGER(I4B), INTENT(IN) :: dim3
+ INTEGER(I4B) :: ans
+ END FUNCTION Get1DIndexFrom3DFortranIndex
+END INTERFACE Get1DIndexFortran
+
+!----------------------------------------------------------------------------
+! Get1DIndexFortran
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-14
+! summary: Convert (i,j,k,l) to ans from Fortran4D array to 1D array
+
+INTERFACE Get1DIndexFortran
+ MODULE PURE FUNCTION Get1DIndexFrom4DFortranIndex(i, j, k, l, dim1, dim2, &
+ dim3, dim4) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: i
+ INTEGER(I4B), INTENT(IN) :: j
+ INTEGER(I4B), INTENT(IN) :: k
+ INTEGER(I4B), INTENT(IN) :: l
+ INTEGER(I4B), INTENT(IN) :: dim1
+ INTEGER(I4B), INTENT(IN) :: dim2
+ INTEGER(I4B), INTENT(IN) :: dim3
+ INTEGER(I4B), INTENT(IN) :: dim4
+ INTEGER(I4B) :: ans
+ END FUNCTION Get1DIndexFrom4DFortranIndex
+END INTERFACE Get1DIndexFortran
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/modules/Utility/src/MappingUtility.F90 b/src/modules/Utility/src/MappingUtility.F90
index 7b5f52e97..050034abe 100644
--- a/src/modules/Utility/src/MappingUtility.F90
+++ b/src/modules/Utility/src/MappingUtility.F90
@@ -17,7 +17,7 @@
!> author: Vikas Sharma, Ph. D.
! date: 19 Oct 2022
-! summary: Some methods related to standard mapping are defined
+! summary: Some methods related to standard mapping are defined
!
!{!pages/MappingUtility_.md!}
@@ -27,13 +27,21 @@ MODULE MappingUtility
PRIVATE
PUBLIC :: FromBiunitLine2Segment
+PUBLIC :: FromBiunitLine2Segment_
PUBLIC :: FromBiUnitLine2UnitLine
PUBLIC :: FromUnitLine2BiUnitLine
+PUBLIC :: FromUnitLine2BiUnitLine_
PUBLIC :: FromLine2Line_
PUBLIC :: FromBiUnitQuadrangle2Quadrangle
+PUBLIC :: FromBiUnitQuadrangle2Quadrangle_
+
PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle
+PUBLIC :: FromBiUnitQuadrangle2UnitQuadrangle_
PUBLIC :: FromUnitQuadrangle2BiUnitQuadrangle
+PUBLIC :: FromBiUnitHexahedron2Hexahedron_
+PUBLIC :: FromBiUnitHexahedron2UnitHexahedron_
+PUBLIC :: FromUnitHexahedron2BiUnitHexahedron_
PUBLIC :: FromBiUnitHexahedron2Hexahedron
PUBLIC :: FromBiUnitHexahedron2UnitHexahedron
@@ -52,8 +60,10 @@ MODULE MappingUtility
PUBLIC :: FromBiUnitQuadrangle2UnitTriangle
PUBLIC :: FromTriangle2Square_
+PUBLIC :: FromSquare2Triangle_
PUBLIC :: FromUnitTriangle2Triangle
+PUBLIC :: FromUnitTriangle2Triangle_
PUBLIC :: BarycentricCoordUnitTriangle
!! This is function
@@ -70,16 +80,27 @@ MODULE MappingUtility
PUBLIC :: FromTriangle2Triangle_
PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron
+PUBLIC :: FromUnitTetrahedron2BiUnitTetrahedron_
+
PUBLIC :: FromBiUnitTetrahedron2UnitTetrahedron
PUBLIC :: FromUnitTetrahedron2Tetrahedron
+PUBLIC :: FromUnitTetrahedron2Tetrahedron_
PUBLIC :: FromBiUnitTetrahedron2Tetrahedron
PUBLIC :: BarycentricCoordUnitTetrahedron
+PUBLIC :: BarycentricCoordUnitTetrahedron_
PUBLIC :: BarycentricCoordBiUnitTetrahedron
+PUBLIC :: BarycentricCoordBiUnitTetrahedron_
PUBLIC :: BarycentricCoordTetrahedron
+PUBLIC :: BarycentricCoordTetrahedron_
PUBLIC :: FromBiUnitTetrahedron2BiUnitHexahedron
+
PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron
+PUBLIC :: FromBiUnitHexahedron2BiUnitTetrahedron_
+
PUBLIC :: FromUnitTetrahedron2BiUnitHexahedron
+
PUBLIC :: FromBiUnitHexahedron2UnitTetrahedron
+PUBLIC :: FromBiUnitHexahedron2UnitTetrahedron_
PUBLIC :: JacobianLine
PUBLIC :: JacobianTriangle
@@ -97,7 +118,7 @@ MODULE MappingUtility
! date: 19 Oct 2022
! summary: Map from unit line to physical space
-INTERFACE
+INTERFACE FromBiunitLine2Segment
MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans)
REAL(DFP), INTENT(IN) :: xin(:)
!! coordinates in [-1,1]
@@ -108,12 +129,26 @@ MODULE PURE FUNCTION FromBiunitLine2Segment1(xin, x1, x2) RESULT(ans)
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
+!----------------------------------------------------------------------------
+! FromBiunitLine2Segment_
+!----------------------------------------------------------------------------
+
+INTERFACE FromBiunitLine2Segment_
+ MODULE PURE SUBROUTINE FromBiunitLine2Segment1_(xin, x1, x2, ans, tsize)
+ 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), INTENT(INOUT) :: ans(:)
+ !! mapped coordinates of xin in physical domain
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE FromBiunitLine2Segment1_
+END INTERFACE FromBiunitLine2Segment_
+
!----------------------------------------------------------------------------
! FromBiunitLine2Segment
!----------------------------------------------------------------------------
@@ -122,7 +157,7 @@ END FUNCTION FromBiunitLine2Segment1
! date: 19 Oct 2022
! summary: Map from unit line to physical space
-INTERFACE
+INTERFACE FromBiunitLine2Segment
MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans)
REAL(DFP), INTENT(IN) :: xin(:)
!! coordinates in [-1,1], SIZE(xin) = n
@@ -134,12 +169,32 @@ MODULE PURE FUNCTION FromBiunitLine2Segment2(xin, x1, x2) RESULT(ans)
!! returned coordinates in physical space
!! ans is in xij format
END FUNCTION FromBiunitLine2Segment2
-END INTERFACE
-
-INTERFACE FromBiunitLine2Segment
- MODULE PROCEDURE FromBiunitLine2Segment2
END INTERFACE FromBiunitLine2Segment
+!----------------------------------------------------------------------------
+! FromBiunitLine2Segment
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 19 Oct 2022
+! summary: from bi unit line to segment wo allocation
+
+INTERFACE FromBiunitLine2Segment_
+ MODULE PURE SUBROUTINE FromBiunitLine2Segment2_(xin, x1, x2, ans, nrow, &
+ ncol)
+ 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), INTENT(INOUT) :: ans(:, :)
+ !! returned coordinates in physical space
+ !! ans is in xij format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE FromBiunitLine2Segment2_
+END INTERFACE FromBiunitLine2Segment_
+
!----------------------------------------------------------------------------
! FromUnitTriangle2Triangle
!----------------------------------------------------------------------------
@@ -167,7 +222,36 @@ END FUNCTION FromUnitTriangle2Triangle1
END INTERFACE FromUnitTriangle2Triangle
!----------------------------------------------------------------------------
-! FromBiUnitQuadrangle2Quadrangle
+! FromUnitTriangle2Triangle_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-26
+! summary: from unit triangle to triangle without allocation
+
+INTERFACE FromUnitTriangle2Triangle_
+ MODULE PURE SUBROUTINE FromUnitTriangle2Triangle1_(xin, x1, x2, x3, ans, &
+ nrow, ncol)
+ 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), INTENT(INOUT) :: ans(:, :)
+ ! REAL(DFP) :: ans(SIZE(x1), SIZE(xin, 2))
+ !! mapped coordinates of xin in physical domain
+ !! shape(ans) = nsd, N
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE FromUnitTriangle2Triangle1_
+END INTERFACE FromUnitTriangle2Triangle_
+
+!----------------------------------------------------------------------------
+! FromBiUnitQuadrangle2UnitQuadrangle
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -176,7 +260,7 @@ END FUNCTION FromUnitTriangle2Triangle1
INTERFACE FromBiUnitQuadrangle2UnitQuadrangle
MODULE PURE FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1(xin) &
- & RESULT(ans)
+ RESULT(ans)
REAL(DFP), INTENT(IN) :: xin(:, :)
!! vertex coordinate of biunit Quadrangle in xij format
!! SIZE(xin,1) = 2
@@ -187,7 +271,26 @@ END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1
END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle
!----------------------------------------------------------------------------
-! FromBiUnitQuadrangle2Quadrangle
+!
+!----------------------------------------------------------------------------
+
+INTERFACE FromBiUnitQuadrangle2UnitQuadrangle_
+ MODULE PURE SUBROUTINE FromBiUnitQuadrangle2UnitQuadrangle1_(xin, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! vertex coordinate of biunit Quadrangle in xij format
+ !! SIZE(xin,1) = 2
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! mapped coordinates of xin in physical domain
+ !! shape(ans) = nsd, N
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xin, 1)
+ !! ncol = SIZE(xin, 2)
+ END SUBROUTINE FromBiUnitQuadrangle2UnitQuadrangle1_
+END INTERFACE FromBiUnitQuadrangle2UnitQuadrangle_
+
+!----------------------------------------------------------------------------
+! FromUnitQuadrangle2BiUnitQuadrangle
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -196,7 +299,7 @@ END FUNCTION FromBiUnitQuadrangle2UnitQuadrangle1
INTERFACE FromUnitQuadrangle2BiUnitQuadrangle
MODULE PURE FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1(xin) &
- & RESULT(ans)
+ RESULT(ans)
REAL(DFP), INTENT(IN) :: xin(:, :)
!! vertex coordinate of biunit Quadrangle in xij format
!! SIZE(xin,1) = 2
@@ -216,7 +319,7 @@ END FUNCTION FromUnitQuadrangle2BiUnitQuadrangle1
INTERFACE FromBiUnitQuadrangle2Quadrangle
MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) &
- & RESULT(ans)
+ RESULT(ans)
REAL(DFP), INTENT(IN) :: xin(:, :)
!! vertex coordinate of biunit Quadrangle in xij format
!! SIZE(xin,1) = 2
@@ -234,6 +337,36 @@ MODULE PURE FUNCTION FromBiUnitQuadrangle2Quadrangle1(xin, x1, x2, x3, x4) &
END FUNCTION FromBiUnitQuadrangle2Quadrangle1
END INTERFACE FromBiUnitQuadrangle2Quadrangle
+!----------------------------------------------------------------------------
+! FromBiUnitQuadrangle2Quadrangle_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 19 Oct 2022
+! summary: Map from unit line to physical space
+
+INTERFACE FromBiUnitQuadrangle2Quadrangle_
+ MODULE PURE SUBROUTINE FromBiUnitQuadrangle2Quadrangle1_(xin, x1, x2, x3, &
+ x4, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! vertex coordinate of biunit Quadrangle in xij format
+ !! SIZE(xin,1) = 2
+ REAL(DFP), INTENT(IN) :: x1(:)
+ !! vertex x1 of physical domain, size(x1) = nsd
+ REAL(DFP), INTENT(IN) :: x2(:)
+ !! vertex x2 of physical domain, size(x2) = nsd
+ REAL(DFP), INTENT(IN) :: x3(:)
+ !! vertex x3 of physical domain, size(x3) = nsd
+ REAL(DFP), INTENT(IN) :: x4(:)
+ !! vertex x4 of physical domain, size(x4) = nsd
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(x1), SIZE(xin, 2))
+ !! mapped coordinates of xin in physical domain
+ !! shape(ans) = nsd, N
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE FromBiUnitQuadrangle2Quadrangle1_
+END INTERFACE FromBiUnitQuadrangle2Quadrangle_
+
!----------------------------------------------------------------------------
! FromBiUnitHexahedron2Hexahedron
!----------------------------------------------------------------------------
@@ -271,6 +404,41 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2Hexahedron1(xin, &
END FUNCTION FromBiUnitHexahedron2Hexahedron1
END INTERFACE FromBiUnitHexahedron2Hexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE FromBiUnitHexahedron2Hexahedron_
+ MODULE PURE SUBROUTINE FromBiUnitHexahedron2Hexahedron1_(xin, x1, x2, x3, &
+ x4, x5, x6, x7, x8, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! vertex coordinate of biunit Hexahedron in xij format
+ !! SIZE(xin,1) = 3
+ REAL(DFP), INTENT(IN) :: x1(:)
+ !! vertex x1 of physical domain, size(x1) = nsd
+ REAL(DFP), INTENT(IN) :: x2(:)
+ !! vertex x2 of physical domain, size(x2) = nsd
+ REAL(DFP), INTENT(IN) :: x3(:)
+ !! vertex x3 of physical domain, size(x3) = nsd
+ REAL(DFP), INTENT(IN) :: x4(:)
+ !! vertex x4 of physical domain, size(x4) = nsd
+ REAL(DFP), INTENT(IN) :: x5(:)
+ !! vertex x5 of physical domain, size(x5) = nsd
+ REAL(DFP), INTENT(IN) :: x6(:)
+ !! vertex x6 of physical domain, size(x6) = nsd
+ REAL(DFP), INTENT(IN) :: x7(:)
+ !! vertex x7 of physical domain, size(x7) = nsd
+ REAL(DFP), INTENT(IN) :: x8(:)
+ !! vertex x8 of physical domain, size(x8) = nsd
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! mapped coordinates of xin in physical domain
+ !! shape(ans) = nsd, N
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(x1)
+ !! ncol = SIZE(xin, 2)
+ END SUBROUTINE FromBiUnitHexahedron2Hexahedron1_
+END INTERFACE FromBiUnitHexahedron2Hexahedron_
+
!----------------------------------------------------------------------------
! FromBiUnitHexahedron2Hexahedron
!----------------------------------------------------------------------------
@@ -291,6 +459,26 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2UnitHexahedron1(xin) &
END FUNCTION FromBiUnitHexahedron2UnitHexahedron1
END INTERFACE FromBiUnitHexahedron2UnitHexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE FromBiUnitHexahedron2UnitHexahedron_
+ MODULE PURE SUBROUTINE FromBiUnitHexahedron2UnitHexahedron1_(xin, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! vertex coordinate of biunit Hexahedron in xij format
+ !! SIZE(xin,1) = 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! mapped coordinates of xin in physical domain
+ !! shape(ans) = nsd, N
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ !! nrow = SIZE(xin, 1)
+ !! ncol = SIZE(xin, 2)
+ END SUBROUTINE FromBiUnitHexahedron2UnitHexahedron1_
+END INTERFACE FromBiUnitHexahedron2UnitHexahedron_
+
!----------------------------------------------------------------------------
! FromBiUnitHexahedron2Hexahedron
!----------------------------------------------------------------------------
@@ -311,6 +499,26 @@ MODULE PURE FUNCTION FromUnitHexahedron2BiUnitHexahedron1(xin) &
END FUNCTION FromUnitHexahedron2BiUnitHexahedron1
END INTERFACE FromUnitHexahedron2BiUnitHexahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE FromUnitHexahedron2BiUnitHexahedron_
+
+ MODULE PURE SUBROUTINE FromUnitHexahedron2BiUnitHexahedron1_(xin, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! vertex coordinate of biunit Hexahedron in xij format
+ !! SIZE(xin,1) = 3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! mapped coordinates of xin in physical domain
+ !! shape(ans) = nsd, N
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xin, 1)
+ !! ncol = SIZE(xin, 2)
+ END SUBROUTINE FromUnitHexahedron2BiUnitHexahedron1_
+END INTERFACE FromUnitHexahedron2BiUnitHexahedron_
+
!----------------------------------------------------------------------------
! FromBiUnitLine2UnitLine
!----------------------------------------------------------------------------
@@ -355,6 +563,24 @@ MODULE PURE FUNCTION FromUnitLine2BiUnitLine(xin) RESULT(ans)
END FUNCTION FromUnitLine2BiUnitLine
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-03
+! summary: from unit line to bi unit line without allocation
+
+INTERFACE
+ MODULE PURE SUBROUTINE FromUnitLine2BiUnitLine_(xin, ans, tsize)
+ REAL(DFP), INTENT(IN) :: xin(:)
+ !! coordinates in unit line
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! mapped coordinates of xin in biunit line
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE FromUnitLine2BiUnitLine_
+END INTERFACE
+
!----------------------------------------------------------------------------
! FromLine2Line_
!----------------------------------------------------------------------------
@@ -475,12 +701,17 @@ END FUNCTION FromBiUnitSqr2UnitTriangle
! summary: Map from triangle to square
INTERFACE
- MODULE PURE SUBROUTINE FromTriangle2Triangle_(xin, ans, from, to, x1, x2, x3)
+ MODULE PURE SUBROUTINE FromTriangle2Triangle_(xin, ans, nrow, ncol, &
+ from, to, x1, x2, x3)
REAL(DFP), INTENT(IN) :: xin(:, :)
!! coordinates in bi-unit square in xij coordinate
REAL(DFP), INTENT(INOUT) :: ans(:, :)
!! ans(2, SIZE(xin, 2))
!! coordinates in biunit triangle
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ !! nrow=2
+ !! ncol=SIZE(xin, 2)
CHARACTER(*), INTENT(IN) :: from
CHARACTER(*), INTENT(IN) :: to
REAL(DFP), OPTIONAL, INTENT(IN) :: x1(:)
@@ -521,7 +752,7 @@ END SUBROUTINE FromTriangle2Square_
! summary: Map from triangle to square
INTERFACE
- MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to)
+ MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to, nrow, ncol)
REAL(DFP), INTENT(IN) :: xin(:, :)
!! coordinates in bi-unit square in xij coordinate
REAL(DFP), INTENT(INOUT) :: ans(:, :)
@@ -529,6 +760,10 @@ MODULE PURE SUBROUTINE FromSquare2Triangle_(xin, ans, from, to)
!! coordinates in biunit triangle
CHARACTER(*), INTENT(IN) :: from
CHARACTER(*), INTENT(IN) :: to
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written in ans
+ !! nrow = 2
+ !! ncol = SIZE(xin, 2)
END SUBROUTINE FromSquare2Triangle_
END INTERFACE
@@ -636,8 +871,23 @@ MODULE PURE FUNCTION FromBiUnitTetrahedron2UnitTetrahedron(xin) RESULT(ans)
END FUNCTION FromBiUnitTetrahedron2UnitTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE FromBiUnitTetrahedron2UnitTetrahedron_(xin, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ ! REAL(DFP) :: ans(3, SIZE(xin, 2))
+ END SUBROUTINE FromBiUnitTetrahedron2UnitTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! FromUnitTetrahedron2BiUnitTetrahedron
+
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -651,6 +901,20 @@ MODULE PURE FUNCTION FromUnitTetrahedron2BiUnitTetrahedron(xin) RESULT(ans)
END FUNCTION FromUnitTetrahedron2BiUnitTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE FromUnitTetrahedron2BiUnitTetrahedron_(xin, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ ! REAL(DFP) :: ans(3, SIZE(xin, 2))
+ END SUBROUTINE FromUnitTetrahedron2BiUnitTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! FromBiUnitTetrahedron2Tetrahedron
!----------------------------------------------------------------------------
@@ -688,12 +952,8 @@ END FUNCTION FromBiUnitTetrahedron2Tetrahedron
! summary: Unit Tetrahedron to tetrahedron
INTERFACE
- MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron( &
- & xin, &
- & x1, &
- & x2, &
- & x3, &
- & x4) RESULT(ans)
+ MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron(xin, x1, x2, x3, x4) &
+ RESULT(ans)
REAL(DFP), INTENT(IN) :: xin(:, :)
REAL(DFP), INTENT(IN) :: x1(3)
!! Coordinate of tetrahedron node 1
@@ -707,6 +967,32 @@ MODULE PURE FUNCTION FromUnitTetrahedron2Tetrahedron( &
END FUNCTION FromUnitTetrahedron2Tetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+! FromUnitTetrahedron2Tetrahedron_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-28
+! summary: No allocation
+
+INTERFACE
+MODULE PURE SUBROUTINE FromUnitTetrahedron2Tetrahedron_(xin, x1, x2, x3, x4, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ REAL(DFP), INTENT(IN) :: x1(3)
+ !! Coordinate of tetrahedron node 1
+ REAL(DFP), INTENT(IN) :: x2(3)
+ !! Coordinate of tetrahedron node 2
+ REAL(DFP), INTENT(IN) :: x3(3)
+ !! Coordinate of tetrahedron node 3
+ REAL(DFP), INTENT(IN) :: x4(3)
+ !! Coordinate of tetrahedron node 4
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(3, SIZE(xin, 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE FromUnitTetrahedron2Tetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricCoordUnitTetrahedron
!----------------------------------------------------------------------------
@@ -722,6 +1008,20 @@ MODULE PURE FUNCTION BarycentricCoordUnitTetrahedron(xin) RESULT(ans)
END FUNCTION BarycentricCoordUnitTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricCoordUnitTetrahedron_(xin, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(4, SIZE(xin, 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricCoordUnitTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricCoordBiUnitTetrahedron
!----------------------------------------------------------------------------
@@ -737,6 +1037,20 @@ MODULE PURE FUNCTION BarycentricCoordBiUnitTetrahedron(xin) RESULT(ans)
END FUNCTION BarycentricCoordBiUnitTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricCoordBiUnitTetrahedron_(xin, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(4, SIZE(xin, 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricCoordBiUnitTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! BarycentricCoordTetrahedron
!----------------------------------------------------------------------------
@@ -751,6 +1065,22 @@ MODULE PURE FUNCTION BarycentricCoordTetrahedron(xin, refTetrahedron) RESULT(ans
END FUNCTION BarycentricCoordTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE BarycentricCoordTetrahedron_(xin, refTetrahedron, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ CHARACTER(*), INTENT(IN) :: refTetrahedron
+ !! "UNIT" "BIUNIT"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(4, SIZE(xin, 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE BarycentricCoordTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! FromBiUnitTetrahedron2BiUnitHexahedron
!----------------------------------------------------------------------------
@@ -785,6 +1115,22 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron(xin) RESULT(ans)
END FUNCTION FromBiUnitHexahedron2BiUnitTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE FromBiUnitHexahedron2BiUnitTetrahedron_(xin, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! coordinates in bi-unit hexahedron in xij coordinate
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ ! REAL(DFP) :: ans(3, SIZE(xin, 2))
+ !! coordinates in biunit tetrahedron
+ END SUBROUTINE FromBiUnitHexahedron2BiUnitTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! FromUnitTetrahedron2BiUnitHexahedron
!----------------------------------------------------------------------------
@@ -819,6 +1165,25 @@ MODULE PURE FUNCTION FromBiUnitHexahedron2UnitTetrahedron(xin) RESULT(ans)
END FUNCTION FromBiUnitHexahedron2UnitTetrahedron
END INTERFACE
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+
+ MODULE PURE SUBROUTINE FromBiUnitHexahedron2UnitTetrahedron_(xin, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xin(:, :)
+ !! coordinates in biunit hexahedron in xij coordinate
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = 3
+ !! ncol = SIZE(xin, 2)
+ !! coordinates in unit tetrahedron
+ END SUBROUTINE FromBiUnitHexahedron2UnitTetrahedron_
+END INTERFACE
+
!----------------------------------------------------------------------------
! JacobianLine
!----------------------------------------------------------------------------
diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90
index 8bbe18966..b076bf7ea 100644
--- a/src/modules/Utility/src/ProductUtility.F90
+++ b/src/modules/Utility/src/ProductUtility.F90
@@ -16,14 +16,59 @@
!
MODULE ProductUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, REAL32, REAL64, LGT, I4B
+
IMPLICIT NONE
+
PRIVATE
-PUBLIC :: OUTERPROD
+
+PUBLIC :: OuterProd
+PUBLIC :: OuterProd_
+
+PUBLIC :: OTimesTilda
+
PUBLIC :: Cross_Product
PUBLIC :: Vector_Product
PUBLIC :: VectorProduct
+!----------------------------------------------------------------------------
+! OTimesTilda@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-13
+! summary: returns a space-time matrix from time and space matrix
+
+INTERFACE OTimesTilda
+ MODULE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale)
+ REAL(DFP), INTENT(IN) :: a(:, :)
+ REAL(DFP), INTENT(IN) :: b(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: anscoeff
+ REAL(DFP), INTENT(IN) :: scale
+ END SUBROUTINE OTimesTilda1
+END INTERFACE OTimesTilda
+
+!----------------------------------------------------------------------------
+! OtimesTilda@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-13
+! summary: returns a space-time vector from time and space vector
+
+INTERFACE OTimesTilda
+ MODULE SUBROUTINE OTimesTilda2(a, b, ans, tsize, anscoeff, scale)
+ REAL(DFP), INTENT(IN) :: a(:)
+ REAL(DFP), INTENT(IN) :: b(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ REAL(DFP), INTENT(IN) :: anscoeff
+ REAL(DFP), INTENT(IN) :: scale
+ END SUBROUTINE OTimesTilda2
+END INTERFACE OTimesTilda
+
!----------------------------------------------------------------------------
! Cross_Product@ProductMethods
!----------------------------------------------------------------------------
@@ -36,86 +81,103 @@ MODULE ProductUtility
! This FUNCTION evaluate vectors products
! $$\mathbf{ans} = \mathbf{a} \times \mathbf{b}$$
-INTERFACE
+INTERFACE Vector_Product
MODULE PURE FUNCTION vectorProduct_1(a, b) RESULT(c)
! Define INTENT of dummy argument
REAL(REAL64), INTENT(IN) :: a(3), b(3)
REAL(REAL64) :: c(3)
END FUNCTION vectorProduct_1
-END INTERFACE
+END INTERFACE Vector_Product
-INTERFACE
+INTERFACE Vector_Product
MODULE PURE FUNCTION vectorProduct_2(a, b) RESULT(c)
! Define INTENT of dummy argument
REAL(REAL32), INTENT(IN) :: a(3), b(3)
REAL(REAL32) :: c(3)
END FUNCTION vectorProduct_2
-END INTERFACE
+END INTERFACE Vector_Product
INTERFACE Cross_Product
MODULE PROCEDURE vectorProduct_1, vectorProduct_2
END INTERFACE Cross_Product
-INTERFACE Vector_Product
- MODULE PROCEDURE vectorProduct_1, vectorProduct_2
-END INTERFACE Vector_Product
-
INTERFACE VectorProduct
MODULE PROCEDURE vectorProduct_1, vectorProduct_2
END INTERFACE VectorProduct
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 22 March 2021
-! summary: This FUNCTION returns outerproduct(matrix) of two vectors
+! summary: This FUNCTION returns OuterProduct(matrix) of two vectors
!
!# Introduction
!
! $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1(a, b) RESULT(ans)
REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b
REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans
- END FUNCTION outerprod_r1r1
-END INTERFACE
+ END FUNCTION OuterProd_r1r1
+END INTERFACE OuterProd
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PURE SUBROUTINE OuterProd_r1r1_(a, b, anscoeff, scale, ans, nrow, &
+ ncol)
+ REAL(DFP), DIMENSION(:), INTENT(IN) :: a, b
+ REAL(DFP), INTENT(IN) :: anscoeff
+ !! coefficient of ans
+ !! ans = anscoeff * ans + scale * a \otimes b
+ REAL(DFP), INTENT(IN) :: scale
+ !! coefficient of a \otimes b
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! outerprod
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of data written in ans
+ END SUBROUTINE OuterProd_r1r1_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 22 March 2021
-! summary: This FUNCTION returns outerproduct
+! summary: This FUNCTION returns OuterProduct
!
!# Introduction
!
-! This FUNCTION returns outerproduct(matrix) of two vectors
+! This FUNCTION returns OuterProduct(matrix) of two vectors
! - $$\mathbf{ans} = \mathbf{a} \otimes \mathbf{b}$$
-! - If `Sym` is .true. THEN symmetric part is returned
+! - If `sym` is .true. THEN symmetric part is returned
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1s(a, b, Sym) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1s(a, b, sym) RESULT(ans)
! Define INTENT of dummy variables
REAL(DFP), INTENT(IN) :: a(:), b(:)
REAL(DFP), DIMENSION(SIZE(a), SIZE(b)) :: ans
- LOGICAL(LGT), INTENT(IN) :: Sym
- END FUNCTION outerprod_r1r1s
-END INTERFACE
+ LOGICAL(LGT), INTENT(IN) :: sym
+ END FUNCTION OuterProd_r1r1s
+END INTERFACE OuterProd
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1s
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PURE SUBROUTINE OuterProd_r1r1s_(a, b, sym, anscoeff, scale, ans, &
+ nrow, ncol)
+ ! Define INTENT of dummy variables
+ REAL(DFP), INTENT(IN) :: a(:), b(:)
+ LOGICAL(LGT), INTENT(IN) :: sym
+ REAL(DFP), INTENT(IN) :: anscoeff
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE OuterProd_r1r1s_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -123,20 +185,31 @@ END FUNCTION outerprod_r1r1s
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2))
- END FUNCTION outerprod_r1r2
-END INTERFACE
+ END FUNCTION OuterProd_r1r2
+END INTERFACE OuterProd
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2
-END INTERFACE OUTERPROD
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: a x b
+
+INTERFACE OuterProd_
+ MODULE PURE SUBROUTINE OuterProd_r1r2_(a, b, anscoeff, scale, ans, &
+ dim1, dim2, dim3)
+ REAL(DFP), INTENT(IN) :: a(:)
+ REAL(DFP), INTENT(IN) :: b(:, :)
+ REAL(DFP), INTENT(IN) :: anscoeff, scale
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE OuterProd_r1r2_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -144,20 +217,16 @@ END FUNCTION outerprod_r1r2
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r3(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :)
REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3))
- END FUNCTION outerprod_r1r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -165,20 +234,16 @@ END FUNCTION outerprod_r1r3
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r4(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r4(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :, :)
REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), SIZE(b, 4))
- END FUNCTION outerprod_r1r4
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r4
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r4
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -186,8 +251,8 @@ END FUNCTION outerprod_r1r4
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r5(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r5(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :, :, :)
REAL(DFP) :: ans(&
@@ -197,35 +262,27 @@ MODULE PURE FUNCTION outerprod_r1r5(a, b) RESULT(ans)
& SIZE(b, 3),&
& SIZE(b, 4),&
& SIZE(b, 5))
- END FUNCTION outerprod_r1r5
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r5
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r5
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 22 March 2021
-! summary: This FUNCTION returns outerproduct
+! summary: This FUNCTION returns OuterProduct
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b))
- END FUNCTION outerprod_r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -233,8 +290,8 @@ END FUNCTION outerprod_r2r1
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r2(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP) :: ans( &
@@ -242,15 +299,11 @@ MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans)
& SIZE(a, 2),&
& SIZE(b, 1),&
& SIZE(b, 2))
- END FUNCTION outerprod_r2r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -258,8 +311,8 @@ END FUNCTION outerprod_r2r2
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r3(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r3(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :, :)
REAL(DFP) :: ans( &
@@ -268,15 +321,11 @@ MODULE PURE FUNCTION outerprod_r2r3(a, b) RESULT(ans)
& SIZE(b, 1),&
& SIZE(b, 2),&
& SIZE(b, 3))
- END FUNCTION outerprod_r2r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -284,8 +333,8 @@ END FUNCTION outerprod_r2r3
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r4(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r4(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :, :, :)
REAL(DFP) :: ans( &
@@ -295,15 +344,11 @@ MODULE PURE FUNCTION outerprod_r2r4(a, b) RESULT(ans)
& SIZE(b, 2),&
& SIZE(b, 3),&
& SIZE(b, 4))
- END FUNCTION outerprod_r2r4
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r4
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r4
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -311,8 +356,8 @@ END FUNCTION outerprod_r2r4
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP) :: ans(&
@@ -320,15 +365,11 @@ MODULE PURE FUNCTION outerprod_r3r1(a, b) RESULT(ans)
& SIZE(a, 2),&
& SIZE(a, 3),&
& SIZE(b))
- END FUNCTION outerprod_r3r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -336,8 +377,8 @@ END FUNCTION outerprod_r3r1
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r2(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r2(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP) :: ans(&
@@ -346,15 +387,11 @@ MODULE PURE FUNCTION outerprod_r3r2(a, b) RESULT(ans)
& SIZE(a, 3),&
& SIZE(b, 1),&
& SIZE(b, 2))
- END FUNCTION outerprod_r3r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -362,8 +399,8 @@ END FUNCTION outerprod_r3r2
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r3(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r3(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:, :, :)
REAL(DFP) :: ans(&
@@ -373,15 +410,11 @@ MODULE PURE FUNCTION outerprod_r3r3(a, b) RESULT(ans)
& SIZE(b, 1),&
& SIZE(b, 2),&
& SIZE(b, 3))
- END FUNCTION outerprod_r3r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -389,8 +422,8 @@ END FUNCTION outerprod_r3r3
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r4r1(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r4r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP) :: ans(&
@@ -399,15 +432,11 @@ MODULE PURE FUNCTION outerprod_r4r1(a, b) RESULT(ans)
& SIZE(a, 3),&
& SIZE(a, 4),&
& SIZE(b, 1))
- END FUNCTION outerprod_r4r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r4r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r4r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -415,8 +444,8 @@ END FUNCTION outerprod_r4r1
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r4r2(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r4r2(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP) :: ans(&
@@ -426,15 +455,11 @@ MODULE PURE FUNCTION outerprod_r4r2(a, b) RESULT(ans)
& SIZE(a, 4),&
& SIZE(b, 1),&
& SIZE(b, 2))
- END FUNCTION outerprod_r4r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r4r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r4r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd@ProductMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -442,8 +467,8 @@ END FUNCTION outerprod_r4r2
! update: 2021-12-19
! summary: a x b
-INTERFACE
- MODULE PURE FUNCTION outerprod_r5r1(a, b) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r5r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP) :: ans(&
@@ -453,15 +478,11 @@ MODULE PURE FUNCTION outerprod_r5r1(a, b) RESULT(ans)
& SIZE(a, 4),&
& SIZE(a, 5),&
& SIZE(b, 1))
- END FUNCTION outerprod_r5r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r5r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r5r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -469,8 +490,8 @@ END FUNCTION outerprod_r5r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -478,15 +499,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans)
& SIZE(a, 1),&
& SIZE(b, 1),&
& SIZE(c, 1))
- END FUNCTION outerprod_r1r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -494,8 +511,8 @@ END FUNCTION outerprod_r1r1r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r2(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -504,15 +521,11 @@ MODULE PURE FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans)
& SIZE(b, 1),&
& SIZE(c, 1),&
& SIZE(c, 2))
- END FUNCTION outerprod_r1r1r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -520,8 +533,8 @@ END FUNCTION outerprod_r1r1r2
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r3(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :, :)
@@ -531,15 +544,11 @@ MODULE PURE FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans)
& SIZE(c, 1),&
& SIZE(c, 2),&
& SIZE(c, 3))
- END FUNCTION outerprod_r1r1r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -547,8 +556,8 @@ END FUNCTION outerprod_r1r1r3
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r4(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :, :, :)
@@ -559,15 +568,11 @@ MODULE PURE FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans)
& SIZE(c, 2),&
& SIZE(c, 3),&
& SIZE(c, 4))
- END FUNCTION outerprod_r1r1r4
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r4
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r4
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -575,8 +580,8 @@ END FUNCTION outerprod_r1r1r4
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -585,15 +590,11 @@ MODULE PURE FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans)
& SIZE(b, 1),&
& SIZE(b, 2),&
& SIZE(c, 1))
- END FUNCTION outerprod_r1r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -601,8 +602,8 @@ END FUNCTION outerprod_r1r2r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2r2(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -612,15 +613,11 @@ MODULE PURE FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans)
& SIZE(b, 2),&
& SIZE(c, 1),&
& SIZE(c, 2))
- END FUNCTION outerprod_r1r2r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -628,8 +625,8 @@ END FUNCTION outerprod_r1r2r2
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2r3(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:, :, :)
@@ -640,15 +637,11 @@ MODULE PURE FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans)
& SIZE(c, 1),&
& SIZE(c, 2),&
& SIZE(c, 3))
- END FUNCTION outerprod_r1r2r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r2r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -656,8 +649,8 @@ END FUNCTION outerprod_r1r2r3
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r3r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -667,15 +660,11 @@ MODULE PURE FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans)
& SIZE(b, 2),&
& SIZE(b, 3),&
& SIZE(c, 1))
- END FUNCTION outerprod_r1r3r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r3r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -683,8 +672,8 @@ END FUNCTION outerprod_r1r3r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r3r2(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -695,15 +684,11 @@ MODULE PURE FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans)
& SIZE(b, 3),&
& SIZE(c, 1),&
& SIZE(c, 2))
- END FUNCTION outerprod_r1r3r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r3r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -711,8 +696,8 @@ END FUNCTION outerprod_r1r3r2
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r4r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -723,15 +708,11 @@ MODULE PURE FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans)
& SIZE(b, 3),&
& SIZE(b, 4),&
& SIZE(c, 1))
- END FUNCTION outerprod_r1r4r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r4r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r4r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -739,8 +720,8 @@ END FUNCTION outerprod_r1r4r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -749,15 +730,11 @@ MODULE PURE FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans)
& SIZE(a, 2),&
& SIZE(b, 1),&
& SIZE(c, 1))
- END FUNCTION outerprod_r2r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -765,8 +742,8 @@ END FUNCTION outerprod_r2r1r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1r2(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -776,15 +753,11 @@ MODULE PURE FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans)
& SIZE(b, 1),&
& SIZE(c, 1),&
& SIZE(c, 2))
- END FUNCTION outerprod_r2r1r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -792,8 +765,8 @@ END FUNCTION outerprod_r2r1r2
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1r3(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :, :)
@@ -804,15 +777,11 @@ MODULE PURE FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans)
& SIZE(c, 1),&
& SIZE(c, 2),&
& SIZE(c, 3))
- END FUNCTION outerprod_r2r1r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -820,8 +789,8 @@ END FUNCTION outerprod_r2r1r3
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r2r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -831,15 +800,11 @@ MODULE PURE FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans)
& SIZE(b, 1),&
& SIZE(b, 2),&
& SIZE(c, 1))
- END FUNCTION outerprod_r2r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -847,8 +812,8 @@ END FUNCTION outerprod_r2r2r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r2r2(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -859,15 +824,11 @@ MODULE PURE FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans)
& SIZE(b, 2),&
& SIZE(c, 1),&
& SIZE(c, 2))
- END FUNCTION outerprod_r2r2r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -875,8 +836,8 @@ END FUNCTION outerprod_r2r2r2
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r1r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -886,15 +847,11 @@ MODULE PURE FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans)
& SIZE(a, 3),&
& SIZE(b, 1),&
& SIZE(c, 1))
- END FUNCTION outerprod_r3r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -902,8 +859,8 @@ END FUNCTION outerprod_r3r1r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r1r2(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -914,15 +871,11 @@ MODULE PURE FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans)
& SIZE(b, 1),&
& SIZE(c, 1),&
& SIZE(c, 2))
- END FUNCTION outerprod_r3r1r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -930,8 +883,8 @@ END FUNCTION outerprod_r3r1r2
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r2r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -942,15 +895,11 @@ MODULE PURE FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans)
& SIZE(b, 1),&
& SIZE(b, 2),&
& SIZE(c, 1))
- END FUNCTION outerprod_r3r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -958,8 +907,8 @@ END FUNCTION outerprod_r3r2r1
! update: 2021-12-19
! summary: a b c
-INTERFACE
- MODULE PURE FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r4r1r1(a, b, c) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -970,15 +919,11 @@ MODULE PURE FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans)
& SIZE(a, 4),&
& SIZE(b, 1),&
& SIZE(c, 1))
- END FUNCTION outerprod_r4r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r4r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r4r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -986,8 +931,8 @@ END FUNCTION outerprod_r4r1r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r1r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -997,15 +942,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1r1(a, b, c, d) RESULT(ans)
& SIZE(b, 1),&
& SIZE(c, 1),&
& SIZE(d, 1))
- END FUNCTION outerprod_r1r1r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1013,8 +954,8 @@ END FUNCTION outerprod_r1r1r1r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1r2(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r1r2(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1025,15 +966,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1r2(a, b, c, d) RESULT(ans)
& SIZE(c, 1),&
& SIZE(d, 1),&
& SIZE(d, 2))
- END FUNCTION outerprod_r1r1r1r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1041,8 +978,8 @@ END FUNCTION outerprod_r1r1r1r2
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1r3(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r1r3(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1054,15 +991,11 @@ MODULE PURE FUNCTION outerprod_r1r1r1r3(a, b, c, d) RESULT(ans)
& SIZE(d, 1),&
& SIZE(d, 2),&
& SIZE(d, 3))
- END FUNCTION outerprod_r1r1r1r3
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1r3
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1070,8 +1003,8 @@ END FUNCTION outerprod_r1r1r1r3
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r2r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r2r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -1082,15 +1015,11 @@ MODULE PURE FUNCTION outerprod_r1r1r2r1(a, b, c, d) RESULT(ans)
& SIZE(c, 1),&
& SIZE(c, 2),&
& SIZE(d, 1))
- END FUNCTION outerprod_r1r1r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1098,8 +1027,8 @@ END FUNCTION outerprod_r1r1r2r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r2r2(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r2r2(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -1111,15 +1040,11 @@ MODULE PURE FUNCTION outerprod_r1r1r2r2(a, b, c, d) RESULT(ans)
& SIZE(c, 2),&
& SIZE(d, 1),&
& SIZE(d, 2))
- END FUNCTION outerprod_r1r1r2r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r2r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1127,8 +1052,8 @@ END FUNCTION outerprod_r1r1r2r2
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r3r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r1r3r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :, :)
@@ -1140,15 +1065,11 @@ MODULE PURE FUNCTION outerprod_r1r1r3r1(a, b, c, d) RESULT(ans)
& SIZE(c, 2),&
& SIZE(c, 3),&
& SIZE(d, 1))
- END FUNCTION outerprod_r1r1r3r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r3r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r1r3r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1156,8 +1077,8 @@ END FUNCTION outerprod_r1r1r3r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r1r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2r1r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1168,15 +1089,11 @@ MODULE PURE FUNCTION outerprod_r1r2r1r1(a, b, c, d) RESULT(ans)
& SIZE(b, 2),&
& SIZE(c, 1),&
& SIZE(d, 1))
- END FUNCTION outerprod_r1r2r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r2r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1184,8 +1101,8 @@ END FUNCTION outerprod_r1r2r1r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r1r2(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2r1r2(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1197,15 +1114,11 @@ MODULE PURE FUNCTION outerprod_r1r2r1r2(a, b, c, d) RESULT(ans)
& SIZE(c, 1),&
& SIZE(d, 1),&
& SIZE(d, 2))
- END FUNCTION outerprod_r1r2r1r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r1r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r2r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1213,8 +1126,8 @@ END FUNCTION outerprod_r1r2r1r2
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r2r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r2r2r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -1226,15 +1139,11 @@ MODULE PURE FUNCTION outerprod_r1r2r2r1(a, b, c, d) RESULT(ans)
& SIZE(c, 1),&
& SIZE(c, 2),&
& SIZE(d, 1))
- END FUNCTION outerprod_r1r2r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r2r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1242,8 +1151,8 @@ END FUNCTION outerprod_r1r2r2r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3r1r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r1r3r1r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:, :, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1255,15 +1164,11 @@ MODULE PURE FUNCTION outerprod_r1r3r1r1(a, b, c, d) RESULT(ans)
& SIZE(b, 3),&
& SIZE(c, 1),&
& SIZE(d, 1))
- END FUNCTION outerprod_r1r3r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r1r3r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1271,8 +1176,8 @@ END FUNCTION outerprod_r1r3r1r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r1r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1r1r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1283,15 +1188,11 @@ MODULE PURE FUNCTION outerprod_r2r1r1r1(a, b, c, d) RESULT(ans)
& SIZE(b, 1),&
& SIZE(c, 1),&
& SIZE(d, 1))
- END FUNCTION outerprod_r2r1r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1299,8 +1200,8 @@ END FUNCTION outerprod_r2r1r1r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r1r2(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1r1r2(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1312,15 +1213,11 @@ MODULE PURE FUNCTION outerprod_r2r1r1r2(a, b, c, d) RESULT(ans)
& SIZE(c, 1),&
& SIZE(d, 1),&
& SIZE(d, 2))
- END FUNCTION outerprod_r2r1r1r2
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r1r2
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1328,8 +1225,8 @@ END FUNCTION outerprod_r2r1r1r2
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r2r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r1r2r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
@@ -1341,15 +1238,11 @@ MODULE PURE FUNCTION outerprod_r2r1r2r1(a, b, c, d) RESULT(ans)
& SIZE(c, 1),&
& SIZE(c, 2),&
& SIZE(d, 1))
- END FUNCTION outerprod_r2r1r2r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r2r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r1r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1357,8 +1250,8 @@ END FUNCTION outerprod_r2r1r2r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2r1r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r2r2r1r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1370,15 +1263,11 @@ MODULE PURE FUNCTION outerprod_r2r2r1r1(a, b, c, d) RESULT(ans)
& SIZE(b, 2),&
& SIZE(c, 1),&
& SIZE(d, 1))
- END FUNCTION outerprod_r2r2r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r2r2r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd@PROD
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1386,8 +1275,8 @@ END FUNCTION outerprod_r2r2r1r1
! update: 2021-12-19
! summary: a b c d
-INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1r1r1(a, b, c, d) RESULT(ans)
+INTERFACE OuterProd
+ MODULE PURE FUNCTION OuterProd_r3r1r1r1(a, b, c, d) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
@@ -1399,12 +1288,8 @@ MODULE PURE FUNCTION outerprod_r3r1r1r1(a, b, c, d) RESULT(ans)
& SIZE(b, 1),&
& SIZE(c, 1),&
& SIZE(d, 1))
- END FUNCTION outerprod_r3r1r1r1
-END INTERFACE
-
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1r1r1
-END INTERFACE OUTERPROD
+ END FUNCTION OuterProd_r3r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
!
diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90
index 132063cdf..8d9f989f7 100644
--- a/src/modules/Utility/src/ReallocateUtility.F90
+++ b/src/modules/Utility/src/ReallocateUtility.F90
@@ -16,8 +16,11 @@
!
MODULE ReallocateUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, LGT, I4B, REAL32, REAL64, REAL128, &
+ INT8, INT16, INT32, INT64
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: Reallocate
@@ -27,9 +30,15 @@ MODULE ReallocateUtility
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_logical(Mat, row)
- LOGICAL(LGT), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_logical(mat, row, isExpand, expandFactor)
+ LOGICAL(LGT), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size if more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor time row
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
+ !! expand factor, used when isExpand is true.
END SUBROUTINE Reallocate_logical
END INTERFACE Reallocate
@@ -38,9 +47,14 @@ END SUBROUTINE Reallocate_logical
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R1(Mat, row)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R1(mat, row, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R1
END INTERFACE Reallocate
@@ -49,9 +63,14 @@ END SUBROUTINE Reallocate_Real64_R1
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R1b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R1b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R1b
END INTERFACE Reallocate
@@ -60,9 +79,14 @@ END SUBROUTINE Reallocate_Real64_R1b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R1(Mat, row)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R1(mat, row, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R1
END INTERFACE Reallocate
@@ -71,9 +95,14 @@ END SUBROUTINE Reallocate_Real32_R1
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R1b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R1b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R1b
END INTERFACE Reallocate
@@ -82,9 +111,14 @@ END SUBROUTINE Reallocate_Real32_R1b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R2(Mat, row, col)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R2(mat, row, col, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: row, col
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R2
END INTERFACE Reallocate
@@ -93,9 +127,14 @@ END SUBROUTINE Reallocate_Real64_R2
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R2b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R2b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R2b
END INTERFACE Reallocate
@@ -104,9 +143,14 @@ END SUBROUTINE Reallocate_Real64_R2b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R2(Mat, row, col)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R2(mat, row, col, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: row, col
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R2
END INTERFACE Reallocate
@@ -115,9 +159,14 @@ END SUBROUTINE Reallocate_Real32_R2
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R2b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R2b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R2b
END INTERFACE Reallocate
@@ -126,9 +175,14 @@ END SUBROUTINE Reallocate_Real32_R2b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R3(Mat, i1, i2, i3)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R3(mat, i1, i2, i3, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R3
END INTERFACE Reallocate
@@ -137,9 +191,14 @@ END SUBROUTINE Reallocate_Real64_R3
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R3b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R3b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R3b
END INTERFACE Reallocate
@@ -148,9 +207,14 @@ END SUBROUTINE Reallocate_Real64_R3b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R3(Mat, i1, i2, i3)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R3(mat, i1, i2, i3, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R3
END INTERFACE Reallocate
@@ -159,9 +223,14 @@ END SUBROUTINE Reallocate_Real32_R3
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R3b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R3b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R3b
END INTERFACE Reallocate
@@ -170,9 +239,14 @@ END SUBROUTINE Reallocate_Real32_R3b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R4(Mat, i1, i2, i3, i4)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R4(mat, i1, i2, i3, i4, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R4
END INTERFACE Reallocate
@@ -181,9 +255,14 @@ END SUBROUTINE Reallocate_Real64_R4
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R4b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R4b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R4b
END INTERFACE Reallocate
@@ -192,9 +271,14 @@ END SUBROUTINE Reallocate_Real64_R4b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R4(Mat, i1, i2, i3, i4)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R4
END INTERFACE Reallocate
@@ -203,9 +287,14 @@ END SUBROUTINE Reallocate_Real32_R4
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R4b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R4b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R4b
END INTERFACE Reallocate
@@ -214,9 +303,14 @@ END SUBROUTINE Reallocate_Real32_R4b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R5(Mat, i1, i2, i3, i4, i5)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R5
END INTERFACE Reallocate
@@ -225,9 +319,14 @@ END SUBROUTINE Reallocate_Real64_R5
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R5b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R5b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R5b
END INTERFACE Reallocate
@@ -236,9 +335,14 @@ END SUBROUTINE Reallocate_Real64_R5b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R5(Mat, i1, i2, i3, i4, i5)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R5(mat, i1, i2, i3, i4, i5, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R5
END INTERFACE Reallocate
@@ -247,9 +351,14 @@ END SUBROUTINE Reallocate_Real32_R5
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R5b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R5b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R5b
END INTERFACE Reallocate
@@ -258,9 +367,15 @@ END SUBROUTINE Reallocate_Real32_R5b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R6(Mat, i1, i2, i3, i4, i5, i6)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R6(mat, i1, i2, i3, i4, i5, i6, &
+ isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R6
END INTERFACE Reallocate
@@ -269,9 +384,14 @@ END SUBROUTINE Reallocate_Real64_R6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R6b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R6b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R6b
END INTERFACE Reallocate
@@ -280,9 +400,14 @@ END SUBROUTINE Reallocate_Real64_R6b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R6(Mat, i1, i2, i3, i4, i5, i6)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R6(mat, i1, i2, i3, i4, i5, i6, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R6
END INTERFACE Reallocate
@@ -291,9 +416,14 @@ END SUBROUTINE Reallocate_Real32_R6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R6b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R6b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R6b
END INTERFACE Reallocate
@@ -302,10 +432,15 @@ END SUBROUTINE Reallocate_Real32_R6b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R7(Mat, i1, i2, i3, i4, i5, &
- & i6, i7)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R7(mat, i1, i2, i3, i4, i5, &
+ & i6, i7, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R7
END INTERFACE Reallocate
@@ -314,9 +449,14 @@ END SUBROUTINE Reallocate_Real64_R7
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R7b(Mat, s)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R7b(mat, s, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R7b
END INTERFACE Reallocate
@@ -325,9 +465,15 @@ END SUBROUTINE Reallocate_Real64_R7b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R7(Mat, i1, i2, i3, i4, i5, i6, i7)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R7(mat, i1, i2, i3, i4, i5, i6, &
+ i7, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R7
END INTERFACE Reallocate
@@ -336,9 +482,14 @@ END SUBROUTINE Reallocate_Real32_R7
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R7b(Mat, s)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R7b(mat, s, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R7b
END INTERFACE Reallocate
@@ -347,9 +498,14 @@ END SUBROUTINE Reallocate_Real32_R7b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R1(Mat, row)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R1(mat, row, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R1
END INTERFACE Reallocate
@@ -358,9 +514,14 @@ END SUBROUTINE Reallocate_Int64_R1
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE SUBROUTINE Reallocate_Int64_R1b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R1b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R1b
END INTERFACE
@@ -373,9 +534,14 @@ END SUBROUTINE Reallocate_Int64_R1b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R1(Mat, row)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R1(mat, row, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R1
END INTERFACE Reallocate
@@ -384,9 +550,14 @@ END SUBROUTINE Reallocate_Int32_R1
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R1b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R1b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R1b
END INTERFACE Reallocate
@@ -395,9 +566,14 @@ END SUBROUTINE Reallocate_Int32_R1b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int16_R1(Mat, row)
- INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int16_R1(mat, row, isExpand, expandFactor)
+ INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int16_R1
END INTERFACE Reallocate
@@ -406,9 +582,14 @@ END SUBROUTINE Reallocate_Int16_R1
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int16_R1b(Mat, s)
- INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int16_R1b(mat, s, isExpand, expandFactor)
+ INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int16_R1b
END INTERFACE Reallocate
@@ -417,9 +598,14 @@ END SUBROUTINE Reallocate_Int16_R1b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int8_R1(Mat, row)
- INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int8_R1(mat, row, isExpand, expandFactor)
+ INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: row
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int8_R1
END INTERFACE Reallocate
@@ -428,9 +614,14 @@ END SUBROUTINE Reallocate_Int8_R1
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int8_R1b(Mat, s)
- INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:)
+ MODULE PURE SUBROUTINE Reallocate_Int8_R1b(mat, s, isExpand, expandFactor)
+ INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int8_R1b
END INTERFACE Reallocate
@@ -439,44 +630,84 @@ END SUBROUTINE Reallocate_Int8_R1b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R2(Mat, row, col)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R2(mat, row, col, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: row, col
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R2
- MODULE PURE SUBROUTINE Reallocate_Int64_R2b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R2b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R2b
- MODULE PURE SUBROUTINE Reallocate_Int32_R2(Mat, row, col)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R2(mat, row, col, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: row, col
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R2
- MODULE PURE SUBROUTINE Reallocate_Int32_R2b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R2b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R2b
- MODULE PURE SUBROUTINE Reallocate_Int16_R2(Mat, row, col)
- INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int16_R2(mat, row, col, isExpand, expandFactor)
+ INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: row, col
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int16_R2
- MODULE PURE SUBROUTINE Reallocate_Int16_R2b(Mat, s)
- INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int16_R2b(mat, s, isExpand, expandFactor)
+ INTEGER(INT16), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int16_R2b
- MODULE PURE SUBROUTINE Reallocate_Int8_R2(Mat, row, col)
- INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int8_R2(mat, row, col, isExpand, expandFactor)
+ INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: row, col
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int8_R2
- MODULE PURE SUBROUTINE Reallocate_Int8_R2b(Mat, s)
- INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :)
+ MODULE PURE SUBROUTINE Reallocate_Int8_R2b(mat, s, isExpand, expandFactor)
+ INTEGER(INT8), ALLOCATABLE, INTENT(INOUT) :: mat(:, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int8_R2b
END INTERFACE Reallocate
@@ -485,9 +716,14 @@ END SUBROUTINE Reallocate_Int8_R2b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R3(Mat, i1, i2, i3)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R3(mat, i1, i2, i3, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R3
END INTERFACE Reallocate
@@ -496,9 +732,14 @@ END SUBROUTINE Reallocate_Int64_R3
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R3b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R3b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R3b
END INTERFACE Reallocate
@@ -507,9 +748,14 @@ END SUBROUTINE Reallocate_Int64_R3b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R3(Mat, i1, i2, i3)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R3(mat, i1, i2, i3, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R3
END INTERFACE Reallocate
@@ -518,9 +764,14 @@ END SUBROUTINE Reallocate_Int32_R3
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R3b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R3b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R3b
END INTERFACE Reallocate
@@ -529,9 +780,15 @@ END SUBROUTINE Reallocate_Int32_R3b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R4(Mat, i1, i2, i3, i4)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R4(mat, i1, &
+ i2, i3, i4, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R4
END INTERFACE Reallocate
@@ -540,9 +797,14 @@ END SUBROUTINE Reallocate_Int64_R4
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R4b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R4b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R4b
END INTERFACE Reallocate
@@ -551,9 +813,14 @@ END SUBROUTINE Reallocate_Int64_R4b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R4(Mat, i1, i2, i3, i4)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R4(mat, i1, i2, i3, i4, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R4
END INTERFACE Reallocate
@@ -562,9 +829,14 @@ END SUBROUTINE Reallocate_Int32_R4
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R4b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R4b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R4b
END INTERFACE Reallocate
@@ -573,9 +845,15 @@ END SUBROUTINE Reallocate_Int32_R4b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R5(Mat, i1, i2, i3, i4, i5)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R5(mat, i1, i2, i3, i4, i5, &
+ isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R5
END INTERFACE Reallocate
@@ -584,9 +862,14 @@ END SUBROUTINE Reallocate_Int64_R5
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R5b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R5b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R5b
END INTERFACE Reallocate
@@ -595,9 +878,15 @@ END SUBROUTINE Reallocate_Int64_R5b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R5(Mat, i1, i2, i3, i4, i5)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R5(mat, i1, i2, i3, i4, i5, &
+ isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R5
END INTERFACE Reallocate
@@ -606,9 +895,14 @@ END SUBROUTINE Reallocate_Int32_R5
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R5b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R5b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R5b
END INTERFACE Reallocate
@@ -617,9 +911,15 @@ END SUBROUTINE Reallocate_Int32_R5b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R6(Mat, i1, i2, i3, i4, i5, i6)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R6(mat, i1, i2, i3, i4, i5, i6, &
+ isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R6
END INTERFACE Reallocate
@@ -628,9 +928,14 @@ END SUBROUTINE Reallocate_Int64_R6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R6b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R6b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R6b
END INTERFACE Reallocate
@@ -639,9 +944,15 @@ END SUBROUTINE Reallocate_Int64_R6b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R6(Mat, i1, i2, i3, i4, i5, i6)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R6(mat, i1, i2, i3, i4, i5, i6, &
+ isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R6
END INTERFACE Reallocate
@@ -650,9 +961,14 @@ END SUBROUTINE Reallocate_Int32_R6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R6b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R6b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R6b
END INTERFACE Reallocate
@@ -661,10 +977,15 @@ END SUBROUTINE Reallocate_Int32_R6b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R7(Mat, i1, i2, i3, i4, i5, &
- & i6, i7)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R7(mat, i1, i2, i3, i4, i5, &
+ & i6, i7, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R7
END INTERFACE Reallocate
@@ -673,9 +994,14 @@ END SUBROUTINE Reallocate_Int64_R7
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int64_R7b(Mat, s)
- INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int64_R7b(mat, s, isExpand, expandFactor)
+ INTEGER(INT64), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int64_R7b
END INTERFACE Reallocate
@@ -684,9 +1010,15 @@ END SUBROUTINE Reallocate_Int64_R7b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R7(Mat, i1, i2, i3, i4, i5, i6, i7)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R7(mat, i1, i2, i3, i4, i5, i6, &
+ i7, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: i1, i2, i3, i4, i5, i6, i7
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R7
END INTERFACE Reallocate
@@ -695,9 +1027,14 @@ END SUBROUTINE Reallocate_Int32_R7
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R7b(Mat, s)
- INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: Mat(:, :, :, :, :, :, :)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R7b(mat, s, isExpand, expandFactor)
+ INTEGER(INT32), ALLOCATABLE, INTENT(INOUT) :: mat(:, :, :, :, :, :, :)
INTEGER(I4B), INTENT(IN) :: s(:)
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R7b
END INTERFACE Reallocate
@@ -706,13 +1043,18 @@ END SUBROUTINE Reallocate_Int32_R7b
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(Vec1, n1, Vec2, n2, Vec3, &
- & n3, Vec4, n4, Vec5, n5, Vec6, n6)
- INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:)
- INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), &
- & Vec4(:), Vec5(:), Vec6(:)
+ MODULE PURE SUBROUTINE Reallocate_Int32_R1_6(vec1, n1, vec2, n2, vec3, &
+ n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor)
+ INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:)
+ INTEGER(I4B), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), &
+ vec4(:), vec5(:), vec6(:)
INTEGER(I4B), INTENT(IN) :: n1, n2
INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Int32_R1_6
END INTERFACE Reallocate
@@ -721,13 +1063,18 @@ END SUBROUTINE Reallocate_Int32_R1_6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(Vec1, n1, Vec2, &
- & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6)
- REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:)
- REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), &
- & Vec4(:), Vec5(:), Vec6(:)
+ MODULE PURE SUBROUTINE Reallocate_Real64_R1_6(vec1, n1, vec2, &
+ n2, vec3, n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:)
+ REAL(REAL64), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), &
+ vec4(:), vec5(:), vec6(:)
INTEGER(I4B), INTENT(IN) :: n1, n2
INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_R1_6
END INTERFACE Reallocate
@@ -736,13 +1083,18 @@ END SUBROUTINE Reallocate_Real64_R1_6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(Vec1, n1, Vec2, &
- & n2, Vec3, n3, Vec4, n4, Vec5, n5, Vec6, n6)
- REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: Vec1(:), Vec2(:)
- REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: Vec3(:), &
- & Vec4(:), Vec5(:), Vec6(:)
+ MODULE PURE SUBROUTINE Reallocate_Real32_R1_6(vec1, n1, vec2, &
+ n2, vec3, n3, vec4, n4, vec5, n5, vec6, n6, isExpand, expandFactor)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: vec1(:), vec2(:)
+ REAL(REAL32), ALLOCATABLE, OPTIONAL, INTENT(INOUT) :: vec3(:), &
+ vec4(:), vec5(:), vec6(:)
INTEGER(I4B), INTENT(IN) :: n1, n2
INTEGER(I4B), OPTIONAL, INTENT(IN) :: n3, n4, n5, n6
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_R1_6
END INTERFACE Reallocate
@@ -751,10 +1103,16 @@ END SUBROUTINE Reallocate_Real32_R1_6
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_AIJ(A, nA, IA, nIA, JA, nJA)
+ MODULE PURE SUBROUTINE Reallocate_Real64_AIJ(A, nA, IA, nIA, JA, nJA, &
+ isExpand, expandFactor)
REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:)
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:)
INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_AIJ
END INTERFACE Reallocate
@@ -763,10 +1121,16 @@ END SUBROUTINE Reallocate_Real64_AIJ
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_AIJ(A, nA, IA, nIA, JA, nJA)
+ MODULE PURE SUBROUTINE Reallocate_Real32_AIJ(A, nA, IA, nIA, JA, nJA, &
+ isExpand, expandFactor)
REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:)
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:), JA(:)
INTEGER(I4B), INTENT(IN) :: nA, nIA, nJA
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_AIJ
END INTERFACE Reallocate
@@ -775,10 +1139,16 @@ END SUBROUTINE Reallocate_Real32_AIJ
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real64_AI(A, nA, IA, nIA)
+ MODULE PURE SUBROUTINE Reallocate_Real64_AI(A, nA, IA, nIA, isExpand, &
+ expandFactor)
REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: A(:)
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:)
INTEGER(I4B), INTENT(IN) :: nA, nIA
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real64_AI
END INTERFACE Reallocate
@@ -787,10 +1157,16 @@ END SUBROUTINE Reallocate_Real64_AI
!----------------------------------------------------------------------------
INTERFACE Reallocate
- MODULE PURE SUBROUTINE Reallocate_Real32_AI(A, nA, IA, nIA)
+ MODULE PURE SUBROUTINE Reallocate_Real32_AI(A, nA, IA, nIA, isExpand, &
+ expandFactor)
REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: A(:)
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: IA(:)
INTEGER(I4B), INTENT(IN) :: nA, nIA
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isExpand
+ !! if true then we do not allocate if current size is more than required
+ !! in this case if the size is not enough then the new size
+ !! is expandFactor times required size
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: expandFactor
END SUBROUTINE Reallocate_Real32_AI
END INTERFACE Reallocate
diff --git a/src/modules/Utility/src/SortUtility.F90 b/src/modules/Utility/src/SortUtility.F90
index 392e60538..d7e6ce42d 100644
--- a/src/modules/Utility/src/SortUtility.F90
+++ b/src/modules/Utility/src/SortUtility.F90
@@ -16,7 +16,8 @@
!
MODULE SortUtility
-USE GlobalData
+USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, &
+ I4B, DFP
IMPLICIT NONE
PRIVATE
@@ -38,7 +39,7 @@ MODULE SortUtility
! date: 2023-06-27
! summary: Sorting by insertion algorithm
-INTERFACE
+INTERFACE IntroSort
MODULE PURE SUBROUTINE IntroSort_Int8(array)
INTEGER(INT8), INTENT(INOUT) :: array(:)
END SUBROUTINE IntroSort_Int8
@@ -57,16 +58,6 @@ END SUBROUTINE IntroSort_Real32
MODULE PURE SUBROUTINE IntroSort_Real64(array)
REAL(REAL64), INTENT(INOUT) :: array(:)
END SUBROUTINE IntroSort_Real64
-END INTERFACE
-
-INTERFACE IntroSort
- MODULE PROCEDURE &
- & IntroSort_Int8, &
- & IntroSort_Int16, &
- & IntroSort_Int32, &
- & IntroSort_Int64, &
- & IntroSort_Real32, &
- & IntroSort_Real64
END INTERFACE IntroSort
!----------------------------------------------------------------------------
@@ -77,7 +68,7 @@ END SUBROUTINE IntroSort_Real64
! date: 2023-06-27
! summary: Indirect sorting by insertion sort
-INTERFACE
+INTERFACE ArgIntroSort
MODULE PURE SUBROUTINE ArgIntroSort_Int8(array, arg)
INTEGER(INT8), INTENT(IN) :: array(:)
INTEGER(I4B), INTENT(INOUT) :: arg(:)
@@ -107,16 +98,6 @@ MODULE PURE SUBROUTINE ArgIntroSort_Real64(array, arg)
REAL(REAL64), INTENT(IN) :: array(:)
INTEGER(I4B), INTENT(INOUT) :: arg(:)
END SUBROUTINE ArgIntroSort_Real64
-END INTERFACE
-
-INTERFACE ArgIntroSort
- MODULE PROCEDURE &
- & ArgIntroSort_Int8, &
- & ArgIntroSort_Int16, &
- & ArgIntroSort_Int32, &
- & ArgIntroSort_Int64, &
- & ArgIntroSort_Real32, &
- & ArgIntroSort_Real64
END INTERFACE ArgIntroSort
!----------------------------------------------------------------------------
@@ -127,7 +108,7 @@ END SUBROUTINE ArgIntroSort_Real64
! date: 2023-06-27
! summary: Sorting by insertion algorithm
-INTERFACE
+INTERFACE InsertionSort
MODULE PURE SUBROUTINE InsertionSort_Int8(array, low, high)
INTEGER(INT8), INTENT(INOUT) :: array(:)
INTEGER(I4B), INTENT(IN) :: low
@@ -158,16 +139,6 @@ MODULE PURE SUBROUTINE InsertionSort_Real64(array, low, high)
INTEGER(I4B), INTENT(IN) :: low
INTEGER(I4B), INTENT(IN) :: high
END SUBROUTINE InsertionSort_Real64
-END INTERFACE
-
-INTERFACE InsertionSort
- MODULE PROCEDURE &
- & InsertionSort_Int8, &
- & InsertionSort_Int16, &
- & InsertionSort_Int32, &
- & InsertionSort_Int64, &
- & InsertionSort_Real32, &
- & InsertionSort_Real64
END INTERFACE InsertionSort
!----------------------------------------------------------------------------
@@ -178,7 +149,7 @@ END SUBROUTINE InsertionSort_Real64
! date: 2023-06-27
! summary: Indirect sorting by insertion sort
-INTERFACE
+INTERFACE ArgInsertionSort
MODULE PURE SUBROUTINE ArgInsertionSort_Int8(array, arg, low, high)
INTEGER(INT8), INTENT(IN) :: array(:)
INTEGER(I4B), INTENT(INOUT) :: arg(:)
@@ -220,16 +191,6 @@ MODULE PURE SUBROUTINE ArgInsertionSort_Real64(array, arg, low, high)
INTEGER(I4B), INTENT(IN) :: low
INTEGER(I4B), INTENT(IN) :: high
END SUBROUTINE ArgInsertionSort_Real64
-END INTERFACE
-
-INTERFACE ArgInsertionSort
- MODULE PROCEDURE &
- & ArgInsertionSort_Int8, &
- & ArgInsertionSort_Int16, &
- & ArgInsertionSort_Int32, &
- & ArgInsertionSort_Int64, &
- & ArgInsertionSort_Real32, &
- & ArgInsertionSort_Real64
END INTERFACE ArgInsertionSort
!----------------------------------------------------------------------------
@@ -240,7 +201,7 @@ END SUBROUTINE ArgInsertionSort_Real64
! date: 22 March 2021
! summary: Heap Sort
-INTERFACE
+INTERFACE HeapSort
MODULE PURE SUBROUTINE HeapSort_Int8(array)
INTEGER(INT8), INTENT(INOUT) :: array(:)
END SUBROUTINE HeapSort_Int8
@@ -259,11 +220,6 @@ END SUBROUTINE HeapSort_Real32
MODULE PURE SUBROUTINE HeapSort_Real64(array)
REAL(REAL64), INTENT(INOUT) :: array(:)
END SUBROUTINE HeapSort_Real64
-END INTERFACE
-
-INTERFACE HeapSort
- MODULE PROCEDURE HeapSort_Int8, HeapSort_Int16, HeapSort_Int32, &
- & HeapSort_Int64, HeapSort_Real32, HeapSort_Real64
END INTERFACE HeapSort
!----------------------------------------------------------------------------
@@ -274,7 +230,7 @@ END SUBROUTINE HeapSort_Real64
! date: 22 March 2021
! summary: Heap Sort
-INTERFACE
+INTERFACE ArgHeapSort
MODULE PURE SUBROUTINE ArgHeapSort_Int8(array, arg)
INTEGER(INT8), INTENT(IN) :: array(:)
INTEGER(I4B), INTENT(OUT) :: arg(0:)
@@ -304,18 +260,13 @@ MODULE PURE SUBROUTINE ArgHeapSort_Real64(array, arg)
REAL(REAL64), INTENT(IN) :: array(:)
INTEGER(I4B), INTENT(OUT) :: arg(0:)
END SUBROUTINE ArgHeapSort_Real64
-END INTERFACE
-
-INTERFACE ArgHeapSort
- MODULE PROCEDURE ArgHeapSort_Int8, ArgHeapSort_Int16, ArgHeapSort_Int32, &
- & ArgHeapSort_Int64, ArgHeapSort_Real32, ArgHeapSort_Real64
END INTERFACE ArgHeapSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectInt8(vect1, low, high)
INTEGER(INT8), INTENT(INOUT) :: vect1(:)
INTEGER(I4B), INTENT(IN) :: low, high
@@ -340,388 +291,369 @@ MODULE RECURSIVE PURE SUBROUTINE QuickSort1vectReal64(vect1, low, high)
REAL(REAL64), INTENT(INOUT) :: vect1(:)
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE QuickSort1vectReal64
-END INTERFACE
-
-INTERFACE QuickSort
- MODULE PROCEDURE QuickSort1vectInt8, QuickSort1vectInt16, &
- & QuickSort1vectInt32, QuickSort1vectInt64
- MODULE PROCEDURE QuickSort1vectReal32, QuickSort1vectReal64
END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE RECURSIVE PURE SUBROUTINE QuickSort2vectIR(vect1, vect2, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectII(vect1, vect2, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRI(vect1, vect2, low, high)
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort2vectRR(vect1, vect2, low, high)
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIII(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIIR(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRR(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectIRI(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRR(vect1, vect2, vect3, &
- & low, high)
+ low, high)
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRRI(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRIR(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort3vectRII(vect1, vect2, vect3, &
- & low, high)
+ low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIII(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIIR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRI(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIIRR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect2
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect3, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRRI(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRIR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectIRII(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRRI(vect1, vect2, &
- & vect3, vect4, low, high)
+ vect3, vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRIR(vect1, vect2, &
- & vect3, vect4, low, high)
+ vect3, vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRRII(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect3, vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect2
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIRI(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect3
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIIR(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1, vect4
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
+END INTERFACE QuickSort
!----------------------------------------------------------------------------
! QuickSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE QuickSort
MODULE PURE RECURSIVE SUBROUTINE QuickSort4vectRIII(vect1, vect2, vect3, &
- & vect4, low, high)
+ vect4, low, high)
INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: vect2, vect3, vect4
REAL(DFP), DIMENSION(:), INTENT(INOUT) :: vect1
INTEGER(I4B), INTENT(IN) :: low, high
END SUBROUTINE
-END INTERFACE
-
-INTERFACE QuickSort
- MODULE PROCEDURE QuickSort2vectII, &
- & QuickSort2vectIR, QuickSort2vectRR, QuickSort2vectRI, &
- & QuickSort3vectIII, QuickSort3vectIIR, QuickSort3vectIRI, &
- & QuickSort3vectIRR, QuickSort3vectRRR, QuickSort3vectRRI, &
- & QuickSort3vectRIR, QuickSort3vectRII, QuickSort4vectIIII, &
- & QuickSort4vectIIIR, QuickSort4vectIIRI, QuickSort4vectIIRR, &
- & QuickSort4vectIRII, QuickSort4vectIRIR, QuickSort4vectIRRI, &
- & QuickSort4vectIRRR, QuickSort4vectRIII, QuickSort4vectRIIR, &
- & QuickSort4vectRIRI, QuickSort4vectRIRR, QuickSort4vectRRII, &
- & QuickSort4vectRRIR, QuickSort4vectRRRI, QuickSort4vectRRRR
END INTERFACE QuickSort
!----------------------------------------------------------------------------
! Sort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE Sort
MODULE PURE FUNCTION Sort_Int8(x, name) RESULT(ans)
INTEGER(INT8), INTENT(IN) :: x(:)
CHARACTER(*), OPTIONAL, INTENT(IN) :: name
@@ -752,18 +684,13 @@ MODULE PURE FUNCTION Sort_Real64(x, name) RESULT(ans)
CHARACTER(*), OPTIONAL, INTENT(IN) :: name
REAL(REAL64) :: ans(SIZE(x))
END FUNCTION Sort_Real64
-END INTERFACE
-
-INTERFACE Sort
- MODULE PROCEDURE Sort_Int8, Sort_Int16, Sort_Int32, Sort_Int64
- MODULE PROCEDURE Sort_Real32, Sort_Real64
END INTERFACE Sort
!----------------------------------------------------------------------------
! ArgSort
!----------------------------------------------------------------------------
-INTERFACE
+INTERFACE ArgSort
MODULE PURE FUNCTION ArgSort_Int8(x, name) RESULT(ans)
INTEGER(INT8), INTENT(IN) :: x(:)
CHARACTER(*), OPTIONAL, INTENT(IN) :: name
@@ -794,11 +721,6 @@ MODULE PURE FUNCTION ArgSort_Real64(x, name) RESULT(ans)
CHARACTER(*), OPTIONAL, INTENT(IN) :: name
INTEGER(I4B) :: ans(SIZE(x))
END FUNCTION ArgSort_Real64
-END INTERFACE
-
-INTERFACE ArgSort
- MODULE PROCEDURE ArgSort_Int8, ArgSort_Int16, ArgSort_Int32, ArgSort_Int64
- MODULE PROCEDURE ArgSort_Real32, ArgSort_Real64
END INTERFACE ArgSort
!----------------------------------------------------------------------------
diff --git a/src/modules/Utility/src/StringUtility.F90 b/src/modules/Utility/src/StringUtility.F90
index d71a0bb0c..b4ad84c41 100644
--- a/src/modules/Utility/src/StringUtility.F90
+++ b/src/modules/Utility/src/StringUtility.F90
@@ -16,8 +16,11 @@
!
MODULE StringUtility
-USE GlobalData
+USE GlobalData, ONLY: I4B, LGT
+USE String_Class, ONLY: String
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: FindReplace
@@ -39,6 +42,110 @@ MODULE StringUtility
PUBLIC :: ToUpperCase
PUBLIC :: UpperCase
+PUBLIC :: PathJoin
+PUBLIC :: PathBase
+PUBLIC :: PathDir
+
+!----------------------------------------------------------------------------
+! PathBase
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-17
+! summary: Returns the base of the path
+!
+!# Introduction
+!
+! Base returns the last element of path.
+! Trailing slashes are removed before extracting the
+! last element.
+! If the path is empty, Base returns ".".
+! If the path consists entirely of slashes, Base returns "/".
+!
+! func main() {
+! fmt.Println(path.Base("/a/b"))
+! fmt.Println(path.Base("/"))
+! fmt.Println(path.Base(""))
+! }
+! b
+! /
+! .
+
+INTERFACE
+ MODULE PURE FUNCTION PathBase(path) RESULT(ans)
+ CHARACTER(*), INTENT(in) :: path
+ CHARACTER(LEN=:), ALLOCATABLE :: ans
+ END FUNCTION PathBase
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! PathJoin
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-17
+! summary: Join two paths
+
+INTERFACE PathJoin
+ MODULE PURE FUNCTION PathJoin1(path1, path2) RESULT(ans)
+ CHARACTER(*), INTENT(in) :: path1
+ CHARACTER(*), INTENT(in) :: path2
+ CHARACTER(LEN=:), ALLOCATABLE :: ans
+ END FUNCTION PathJoin1
+END INTERFACE PathJoin
+
+!----------------------------------------------------------------------------
+! PathJoin
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-17
+! summary: Join two paths
+
+INTERFACE PathJoin
+ MODULE PURE FUNCTION PathJoin2(paths) RESULT(ans)
+ TYPE(String), INTENT(IN) :: paths(:)
+ CHARACTER(LEN=:), ALLOCATABLE :: ans
+ END FUNCTION PathJoin2
+END INTERFACE PathJoin
+
+!----------------------------------------------------------------------------
+! GetPath@StringMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-17
+! summary: Returns the parent directory
+!
+!# Introduction
+!
+! Dir returns all but the last element of path,
+! typically the path's directory.
+! After dropping the final element using Split,
+! the path is Cleaned and trailing slashes are removed.
+! If the path is empty, Dir returns ".".
+! If the path consists entirely of slashes followed by non-slash bytes,
+! Dir returns a single slash.
+! In any other case, the returned path does not end in a slash.
+
+INTERFACE
+ MODULE PURE FUNCTION PathDir(path) RESULT(ans)
+ CHARACTER(*), INTENT(IN) :: path
+ CHARACTER(:), ALLOCATABLE :: ans
+ END FUNCTION PathDir
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! GetPath@StringMethods
+!----------------------------------------------------------------------------
+
+INTERFACE GetPath
+ MODULE PURE SUBROUTINE GetPath_chars(chars, path)
+ CHARACTER(*), INTENT(IN) :: chars
+ CHARACTER(*), INTENT(OUT) :: path
+ END SUBROUTINE GetPath_chars
+END INTERFACE GetPath
+
!----------------------------------------------------------------------------
! UpperCase@StringMethods
!----------------------------------------------------------------------------
@@ -50,23 +157,23 @@ MODULE StringUtility
INTERFACE UpperCase
MODULE PURE FUNCTION UpperCase_char(chars) RESULT(Ans)
CHARACTER(*), INTENT(IN) :: chars
- CHARACTER(LEN(chars)) :: ans
+ CHARACTER(len=:), ALLOCATABLE :: ans
END FUNCTION UpperCase_char
END INTERFACE UpperCase
!----------------------------------------------------------------------------
-! toUpperCase@StringMethods
+! ToUpperCase@StringMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 Sept 2021
! summary: Returns the upperCase version of chars
-INTERFACE toUpperCase
+INTERFACE ToUpperCase
MODULE PURE SUBROUTINE ToUpperCase_Char(chars)
CHARACTER(*), INTENT(INOUT) :: chars
END SUBROUTINE ToUpperCase_Char
-END INTERFACE toUpperCase
+END INTERFACE ToUpperCase
!----------------------------------------------------------------------------
! LowerCase@StringMethods
@@ -79,53 +186,53 @@ END SUBROUTINE ToUpperCase_Char
INTERFACE LowerCase
MODULE PURE FUNCTION LowerCase_char(chars) RESULT(Ans)
CHARACTER(*), INTENT(IN) :: chars
- CHARACTER(LEN(chars)) :: ans
+ CHARACTER(:), ALLOCATABLE :: ans
END FUNCTION LowerCase_char
END INTERFACE LowerCase
!----------------------------------------------------------------------------
-! toLowerCase@StringMethods
+! ToLowerCase@StringMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 Sept 2021
! summary: Returns the LowerCase version of chars
-INTERFACE toLowerCase
+INTERFACE ToLowerCase
MODULE PURE SUBROUTINE ToLowerCase_Char(chars)
CHARACTER(*), INTENT(INOUT) :: chars
END SUBROUTINE ToLowerCase_Char
-END INTERFACE toLowerCase
+END INTERFACE ToLowerCase
!----------------------------------------------------------------------------
-! isWhiteChar@StringMethods
+! IsWhiteChar@StringMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 Sept 2021
! summary: Returns true if the char is a space(32) or a tab(9).
-INTERFACE isWhiteChar
- MODULE PURE FUNCTION isWhiteChar_char(char) RESULT(Ans)
+INTERFACE IsWhiteChar
+ MODULE PURE FUNCTION IsWhiteChar_char(char) RESULT(Ans)
CHARACTER(1), INTENT(IN) :: char
LOGICAL(LGT) :: ans
- END FUNCTION isWhiteChar_char
-END INTERFACE isWhiteChar
+ END FUNCTION IsWhiteChar_char
+END INTERFACE IsWhiteChar
!----------------------------------------------------------------------------
-! isBlank@StringMethods
+! IsBlank@StringMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 Sept 2021
! summary: Returns true of the entire string is blank
-INTERFACE isBlank
- MODULE PURE FUNCTION isBlank_chars(chars) RESULT(Ans)
+INTERFACE IsBlank
+ MODULE PURE FUNCTION IsBlank_chars(chars) RESULT(Ans)
CHARACTER(*), INTENT(IN) :: chars
LOGICAL(LGT) :: ans
- END FUNCTION isBlank_chars
-END INTERFACE isBlank
+ END FUNCTION IsBlank_chars
+END INTERFACE IsBlank
!----------------------------------------------------------------------------
! numString@StringMethods
@@ -144,12 +251,12 @@ END FUNCTION isBlank_chars
! (https://github.com/CASL/Futility/blob/master/src/IO_Strings.F90)
!
-INTERFACE numStrings
- MODULE PURE FUNCTION numStrings_chars(chars) RESULT(Ans)
+INTERFACE NumStrings
+ MODULE PURE FUNCTION NumStrings_chars(chars) RESULT(Ans)
CHARACTER(*), INTENT(IN) :: chars
INTEGER(I4B) :: ans
- END FUNCTION numStrings_chars
-END INTERFACE numStrings
+ END FUNCTION NumStrings_chars
+END INTERFACE NumStrings
!----------------------------------------------------------------------------
! nmatchstr@StringMethods
@@ -193,14 +300,14 @@ END FUNCTION isPresent_chars
END INTERFACE isPresent
!----------------------------------------------------------------------------
-! strFind@StringMethods
+! StrFind@StringMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 sept 2021
! summary: Function returns the indices in a string where substring pattern
-INTERFACE strFind
+INTERFACE StrFind
MODULE PURE SUBROUTINE strFind_chars(chars, pattern, indices)
CHARACTER(*), INTENT(IN) :: chars
CHARACTER(*), INTENT(IN) :: pattern
@@ -291,17 +398,6 @@ MODULE PURE SUBROUTINE GetFileParts_chars(chars, path, fname, ext)
END SUBROUTINE GetFileParts_chars
END INTERFACE GetFileParts
-!----------------------------------------------------------------------------
-! GetPath@StringMethods
-!----------------------------------------------------------------------------
-
-INTERFACE GetPath
- MODULE PURE SUBROUTINE GetPath_chars(chars, path)
- CHARACTER(*), INTENT(IN) :: chars
- CHARACTER(*), INTENT(OUT) :: path
- END SUBROUTINE GetPath_chars
-END INTERFACE GetPath
-
!----------------------------------------------------------------------------
! GetFileName@StringMethods
!----------------------------------------------------------------------------
diff --git a/src/modules/Utility/src/SwapUtility.F90 b/src/modules/Utility/src/SwapUtility.F90
index 0375e0f00..0304fc55f 100644
--- a/src/modules/Utility/src/SwapUtility.F90
+++ b/src/modules/Utility/src/SwapUtility.F90
@@ -558,6 +558,13 @@ MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, i2)
!! make sure i2 is less than or equal to 2
END SUBROUTINE Swap_index_1
+END INTERFACE Swap_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE Swap_
MODULE PURE SUBROUTINE Swap_index_2(a, b, i1, i2)
REAL(REAL64), INTENT(INOUT) :: a(:, :)
!! the returned array
diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90
index 83e6b7807..39bb81b70 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_DBCMethods@Methods.F90
@@ -20,7 +20,8 @@
! summary: This submodule contains the methods for sparse matrix
SUBMODULE(CSRMatrix_DBCMethods) Methods
-USE BaseMethod
+USE CSRMatrix_Method, ONLY: GetDiagonal, SIZE
+
IMPLICIT NONE
CONTAINS
@@ -29,7 +30,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE csrMat_ApplyDBC
-INTEGER(I4B) :: i, ii, nrow
+INTEGER(I4B) :: i, ii, nrow, tdbcptrs
LOGICAL(LGT), ALLOCATABLE :: mask(:)
REAL(DFP), ALLOCATABLE :: diag_entries(:)
@@ -42,7 +43,9 @@
! make row zeros
- DO CONCURRENT(i=1:SIZE(dbcPtrs))
+ tdbcptrs = SIZE(dbcPtrs)
+
+ DO CONCURRENT(i=1:tdbcptrs)
ii = dbcPtrs(i)
A(IA(ii):IA(ii + 1) - 1) = 0.0_DFP
END DO
diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90
index ac5dcea7d..f41ca5305 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90
@@ -160,21 +160,37 @@
MODULE PROCEDURE obj_Get0
! Internal variables
-INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
+INTEGER(I4B), ALLOCATABLE :: indx(:)
INTEGER(I4B) :: ii, jj
-row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum)
-col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum)
-VALUE = 0.0_DFP
-DO ii = 1, SIZE(row)
- DO jj = 1, SIZE(col)
- CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), &
- & icolumn=col(jj))
+nrow = .tdof. (obj%csr%idof)
+nrow = nrow * SIZE(nodenum)
+
+ncol = .tdof. (obj%csr%jdof)
+ncol = ncol * SIZE(nodenum)
+
+ALLOCATE (indx(nrow + ncol))
+
+CALL GetIndex_(obj=obj%csr%idof, nodeNum=nodenum, &
+ ans=indx(1:), tsize=ii)
+
+CALL GetIndex_(obj=obj%csr%jdof, nodeNum=nodenum, &
+ ans=indx(nrow + 1:), tsize=ii)
+
+! row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum)
+! col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum)
+
+VALUE(1:nrow, 1:ncol) = 0.0_DFP
+
+DO ii = 1, nrow
+ DO jj = 1, ncol
+ CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=indx(ii), &
+ icolumn=indx(nrow + jj))
END DO
END DO
-IF (ALLOCATED(row)) DEALLOCATE (row)
-IF (ALLOCATED(col)) DEALLOCATE (col)
+DEALLOCATE (indx)
+
END PROCEDURE obj_Get0
!----------------------------------------------------------------------------
@@ -185,28 +201,29 @@
REAL(DFP) :: m2(SIZE(VALUE, 1), SIZE(VALUE, 2))
INTEGER(I4B) :: tdof, nns, myfmt
-CALL GetValue(obj=obj, nodenum=nodenum, VALUE=m2)
+CALL GetValue(obj=obj, nodenum=nodenum, VALUE=m2, nrow=nrow, ncol=ncol)
-tdof = .tdof. (obj%csr%idof)
-nns = SIZE(nodenum)
myfmt = GetStorageFMT(obj, 1)
IF (myfmt .EQ. storageFMT) THEN
- VALUE = m2
+ VALUE(1:nrow, 1:ncol) = m2(1:nrow, 1:ncol)
RETURN
END IF
+tdof = .tdof. (obj%csr%idof)
+nns = SIZE(nodenum)
+
SELECT CASE (storageFMT)
CASE (FMT_NODES)
- CALL ConvertSafe(From=m2, To=VALUE, Conversion=DOFToNodes, nns=nns, &
- & tDOF=tdof)
+ CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), &
+ Conversion=DOFToNodes, nns=nns, tDOF=tdof)
CASE (FMT_DOF)
- CALL ConvertSafe(From=m2, To=VALUE, Conversion=NodesToDOF, nns=nns, &
- & tDOF=tdof)
+ CALL ConvertSafe(From=m2(1:nrow, 1:ncol), To=VALUE(1:nrow, 1:ncol), &
+ Conversion=NodesToDOF, nns=nns, tDOF=tdof)
END SELECT
@@ -219,7 +236,7 @@
MODULE PROCEDURE obj_Get2
INTEGER(I4B) :: j
-VALUE = 0.0_DFP
+! VALUE = 0.0_DFP
DO j = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1
IF (obj%csr%JA(j) .EQ. icolumn) THEN
VALUE = obj%A(j)
@@ -234,15 +251,15 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_Get10
-INTEGER(I4B) :: ii, jj, m, n
-
-VALUE = 0.0_DFP
-m = SIZE(irow)
-n = SIZE(icolumn)
-DO ii = 1, m
- DO jj = 1, n
- CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=irow(ii), &
- & icolumn=icolumn(jj))
+INTEGER(I4B) :: ii, jj
+
+! VALUE = 0.0_DFP
+nrow = SIZE(irow)
+ncol = SIZE(icolumn)
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=irow(ii), &
+ icolumn=icolumn(jj))
END DO
END DO
@@ -271,10 +288,13 @@
row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar)
col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar)
-DO ii = 1, SIZE(row)
- DO jj = 1, SIZE(col)
- CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), &
- & icolumn=col(jj))
+nrow = SIZE(row)
+ncol = SIZE(col)
+
+DO ii = 1, nrow
+ DO jj = 1, ncol
+ CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), &
+ icolumn=col(jj))
END DO
END DO
@@ -300,18 +320,18 @@
MODULE PROCEDURE obj_Get6
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, trow, tcol
+INTEGER(I4B) :: ii, jj
row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof)
col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof)
-trow = SIZE(row)
-tcol = SIZE(col)
+nrow = SIZE(row)
+ncol = SIZE(col)
-DO ii = 1, trow
- DO jj = 1, tcol
- CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), &
- & icolumn=col(jj))
+DO ii = 1, nrow
+ DO jj = 1, ncol
+ CALL GetValue(obj=obj, VALUE=VALUE(ii, jj), irow=row(ii), &
+ icolumn=col(jj))
END DO
END DO
@@ -350,22 +370,14 @@
MODULE PROCEDURE obj_Get9
INTEGER(I4B) :: irow(SIZE(iNodeNum)), icolumn(SIZE(jNodeNum))
-irow = GetNodeLoc( &
- & obj=obj%csr%idof, &
- & nodenum=iNodeNum, &
- & ivar=ivar, &
- & spacecompo=ispacecompo, &
- & timecompo=itimecompo)
+irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo)
-icolumn = GetNodeLoc( &
- & obj=obj%csr%jdof, &
- & nodenum=jNodeNum, &
- & ivar=jvar, &
- & spacecompo=jspacecompo, &
- & timecompo=jtimecompo)
+icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo)
-CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE)
-!! Get10
+CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, &
+ nrow=nrow, ncol=ncol)
END PROCEDURE obj_Get9
!----------------------------------------------------------------------------
diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90
index 57773f75f..0abd51aae 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90
@@ -25,10 +25,10 @@
MODULE PROCEDURE obj_GetSubMatrix1
LOGICAL(LGT), ALLOCATABLE :: selectCol(:)
-INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), &
-& icol, jj
+INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), &
+ icol, jj
REAL(DFP) :: aval
-TYPE(String) :: astr
+CHARACTER(:), ALLOCATABLE :: astr
nnz = GetNNZ(obj=obj)
nrow = SIZE(obj, 1)
@@ -41,16 +41,19 @@
nn = SIZE(cols)
DO ii = 1, nn
jj = cols(ii)
+
+#ifdef DEBUG_VER
IF (jj .GT. ncol) THEN
- astr = "Error cols( "//tostring(ii)//") is greater than "// &
- & "ncol = "//tostring(ncol)
- CALL ErrorMSG( &
- & astr%chars(), &
- & "CSRMatrix_GetSubMatrixMethods@Methods.F90", &
- & "obj_GetSubMatrix1()", &
- & __LINE__, stderr)
+ astr = "Error cols( "//tostring(ii)//") is greater than "// &
+ "ncol = "//tostring(ncol)
+ CALL ErrorMSG(msg=astr, &
+ file="CSRMatrix_GetSubMatrixMethods@Methods.F90", &
+ routine="obj_GetSubMatrix1()", &
+ line=__LINE__, unitno=stderr)
STOP
END IF
+#endif
+
selectCol(jj) = .TRUE.
END DO
diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90
index ae4631d4d..5e08cd97f 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_MatVecMethods@Methods.F90
@@ -20,7 +20,15 @@
! summary: This submodule contains the methods for sparse matrix
SUBMODULE(CSRMatrix_MatVecMethods) Methods
-USE BaseMethod
+USE RealVector_Method, ONLY: RealVector_Size => Size
+USE InputUtility, ONLY: Input
+USE F95_BLAS, ONLY: AXPY, SCAL
+USE Display_Method, ONLY: ToString
+USE GlobalData, ONLY: stderr
+USE ErrorHandling, ONLY: Errormsg
+USE CSRMatrix_Method, ONLY: IsSquare, IsRectangle, &
+ CSRMatrix_Size => Size
+
IMPLICIT NONE
CONTAINS
@@ -139,8 +147,8 @@
REAL(DFP) :: scale0
INTEGER(I4B) :: tsize
-add0 = input(default=.FALSE., option=addContribution)
-scale0 = input(default=1.0_DFP, option=scale)
+add0 = Input(default=.FALSE., option=addContribution)
+scale0 = Input(default=1.0_DFP, option=scale)
tsize = SIZE(y)
IF (add0) THEN
@@ -149,8 +157,8 @@
RETURN
END IF
-CALL CSRMatrixAMUX(n=tsize, x=x, y=y, a=obj%A, &
- & ja=obj%csr%JA, ia=obj%csr%IA, s=scale0)
+CALL CSRMatrixAMUX(n=tsize, x=x, y=y, a=obj%A, &
+ ja=obj%csr%JA, ia=obj%csr%IA, s=scale0)
END PROCEDURE csrMat_AMatvec1
@@ -164,8 +172,8 @@
REAL(DFP) :: scale0
INTEGER(I4B) :: tsize
-add0 = input(default=.FALSE., option=addContribution)
-scale0 = input(default=1.0_DFP, option=scale)
+add0 = Input(default=.FALSE., option=addContribution)
+scale0 = Input(default=1.0_DFP, option=scale)
tsize = SIZE(y)
IF (add0) THEN
@@ -190,14 +198,14 @@
LOGICAL(LGT) :: squareCase, problem, rectCase
add0 = INPUT(default=.FALSE., option=addContribution)
-scale0 = input(default=1.0_DFP, option=scale)
+scale0 = Input(default=1.0_DFP, option=scale)
ty = SIZE(y)
tx = SIZE(x)
-squareCase = isSquare(obj)
-rectCase = isRectangle(obj)
+squareCase = IsSquare(obj)
+rectCase = IsRectangle(obj)
-ncol = SIZE(obj, 2) !ncol
-nrow = SIZE(obj, 1) !nrow
+ncol = CSRMatrix_Size(obj, 2) !ncol
+nrow = CSRMatrix_Size(obj, 1) !nrow
problem = tx .NE. nrow .OR. ty .NE. ncol
@@ -208,14 +216,13 @@
END IF
IF (add0 .AND. rectCase .AND. problem) THEN
- CALL Errormsg( &
- & msg="Mismatch in shapes... nrow = "//tostring(nrow)// &
- & " ncol = "//tostring(ncol)//" size(x) = "//tostring(tx)// &
- & " size(y) = "//tostring(ty), &
- & file=__FILE__, &
- & routine="csrMat_AtMatvec()", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg(msg="Mismatch in shapes... nrow = "//ToString(nrow)// &
+ " ncol = "//ToString(ncol)//" size(x) = "//ToString(tx)// &
+ " size(y) = "//ToString(ty), &
+ file=__FILE__, &
+ routine="csrMat_AtMatvec()", &
+ line=__LINE__, &
+ unitno=stderr)
RETURN
END IF
@@ -241,7 +248,7 @@
MODULE PROCEDURE csrMat_MatVec1
LOGICAL(LGT) :: trans
-trans = INPUT(option=isTranspose, default=.FALSE.)
+trans = Input(option=isTranspose, default=.FALSE.)
IF (trans) THEN
CALL AtMatvec(obj=obj, x=x, y=y, addContribution=addContribution, &
@@ -259,7 +266,18 @@
MODULE PROCEDURE csrMat_MatVec2
CALL AMatvec(A=A, JA=JA, x=x, y=y, addContribution=addContribution, &
- & scale=scale)
+ scale=scale)
END PROCEDURE csrMat_MatVec2
+!----------------------------------------------------------------------------
+! MatVec
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE csrMat_MatVec3
+INTEGER(I4B) :: n
+n = RealVector_Size(x)
+CALL csrMat_MatVec1(obj=obj, x=x%val(1:n), y=y%val(1:n), &
+ isTranspose=isTranspose, addContribution=addContribution, scale=scale)
+END PROCEDURE csrMat_MatVec3
+
END SUBMODULE Methods
diff --git a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90 b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90
index 4f0a1cf4a..6ed92c1a6 100644
--- a/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90
+++ b/src/submodules/CSRSparsity/src/CSRSparsity_Method@ConstructorMethods.F90
@@ -63,11 +63,14 @@
problem = tnodes1 .NE. nrow .OR. tnodes2 .NE. ncol
IF (problem) THEN
CALL ErrorMSG( &
- & "Size of the matrix does not conform with the dof data! "// &
- & "tNodes1 = "//tostring(tnodes1)//" tNodes2="//tostring(tNodes2), &
- & "CSRSparsity_Method@Constructor.F90", &
- & "obj_initiate1()", &
- & __LINE__, stderr)
+ msg="Size of the matrix does not conform with the dof data! "// &
+ "tNodes in idof = "//tostring(tnodes1)// &
+ " it should be "//tostring(nrow)// &
+ " tnodes in jdof ="//tostring(tNodes2)// &
+ " it should be "//tostring(ncol), &
+ file="CSRSparsity_Method@Constructor.F90", &
+ routine="obj_initiate1()", &
+ line=__LINE__, unitno=stderr)
STOP
END IF
END IF
diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/CM_10.inc
index 8d647f718..d3a880c66 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_10.inc
+++ b/src/submodules/ConvectiveMatrix/src/CM_10.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE CM_10(ans, test, trial, term1, term2, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & trial%refelem%nsd, 1)
+ & trial%nsd, 1)
!
DO ips = 1, SIZE(realval)
DO ii = 1, SIZE(m4, 3)
@@ -58,7 +58,7 @@ PURE SUBROUTINE CM_10(ans, test, trial, term1, term2, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & 1, trial%refelem%nsd)
+ & 1, trial%nsd)
!
DO ips = 1, SIZE(realval)
DO ii = 1, SIZE(m4, 4)
diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/CM_5.inc
index a4cfc20a8..572670b68 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_5.inc
+++ b/src/submodules/ConvectiveMatrix/src/CM_5.inc
@@ -49,7 +49,7 @@ PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & trial%refelem%nsd, 1)
+ & trial%nsd, 1)
!!
!! test: rowConcat
!!
@@ -61,7 +61,7 @@ PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & 1, trial%refelem%nsd)
+ & 1, trial%nsd)
!!
!! test: rowConcat
!!
diff --git a/src/submodules/ConvectiveMatrix/src/CM_6.inc b/src/submodules/ConvectiveMatrix/src/CM_6.inc
index 06cfb876f..c260ddaa5 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_6.inc
+++ b/src/submodules/ConvectiveMatrix/src/CM_6.inc
@@ -49,7 +49,7 @@ PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & trial%refelem%nsd, 1)
+ & trial%nsd, 1)
!!
DO ips = 1, SIZE(realval)
do ii = 1, size(m4, 3)
@@ -62,7 +62,7 @@ PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & 1, trial%refelem%nsd)
+ & 1, trial%nsd)
!!
DO ips = 1, SIZE(realval)
do ii = 1, size(m4, 4)
diff --git a/src/submodules/ConvectiveMatrix/src/CM_9.inc b/src/submodules/ConvectiveMatrix/src/CM_9.inc
index d7cb134f9..02d011979 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_9.inc
+++ b/src/submodules/ConvectiveMatrix/src/CM_9.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE CM_9(ans, test, trial, term1, term2, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & trial%refelem%nsd, 1)
+ & trial%nsd, 1)
!!
DO ips = 1, SIZE(realval)
DO ii = 1, SIZE(m4, 3)
@@ -57,7 +57,7 @@ PURE SUBROUTINE CM_9(ans, test, trial, term1, term2, opt)
CALL Reallocate(m4, &
& SIZE(test%N, 1), &
& SIZE(trial%N, 1), &
- & 1, trial%refelem%nsd)
+ & 1, trial%nsd)
!!
DO ips = 1, SIZE(realval)
DO ii = 1, SIZE( m4, 4)
diff --git a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90
index 838cc5b12..bad5cdb52 100644
--- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90
+++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90
@@ -35,98 +35,127 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE ConvectiveMatrix_1
-IF( term1 .EQ. DEL_NONE ) THEN
-!!
-!!
-!!
-!!
- IF( term2 .EQ. DEL_X_ALL ) THEN
- !!
+IF (term1 .EQ. DEL_NONE) THEN
+ IF (term2 .EQ. DEL_X_ALL) THEN
!! del_none
!! del_x_all
- !!
CALL CM_9(ans=ans, test=test, trial=trial, &
& term1=term2, term2=term2, opt=opt)
- !!
ELSE
- !!
!! del_none
!! del_x, del_y, del_z
- !!
CALL CM_7(ans=ans, test=test, trial=trial, &
& term1=term2, term2=term2, opt=opt)
!!
END IF
-!!
-!!
-!!
-!!
ELSE
- !!
!! term2 .eq. del_none
- !!
- IF( term1 .EQ. del_x_all ) THEN
- !!
+ IF (term1 .EQ. del_x_all) THEN
!! del_x_all
!! del_none
- !!
CALL CM_10(ans=ans, test=test, trial=trial, &
& term1=term2, term2=term2, opt=opt)
- !!
ELSE
- !!
!! del_x, del_y, del_z
!! del_none
- !!
CALL CM_8(ans=ans, test=test, trial=trial, &
& term1=term2, term2=term2, opt=opt)
- !!
END IF
END IF
-!!
+
END PROCEDURE ConvectiveMatrix_1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ConvectiveMatrix1_
+
+IF (term1 .EQ. DEL_NONE) THEN
+ IF (term2 .EQ. DEL_X_ALL) THEN
+ CALL CM9_(ans=ans, test=test, trial=trial, &
+ & term1=term2, term2=term2, nrow=nrow, ncol=ncol, opt=opt)
+ ELSE
+ CALL CM7_(ans=ans, test=test, trial=trial, &
+ & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ END IF
+ELSE
+ IF (term1 .EQ. del_x_all) THEN
+ CALL CM10_(ans=ans, test=test, trial=trial, &
+ & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ ELSE
+ CALL CM8_(ans=ans, test=test, trial=trial, &
+ & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ END IF
+END IF
+
+END PROCEDURE ConvectiveMatrix1_
+
!----------------------------------------------------------------------------
! ConvectiveMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE ConvectiveMatrix_2
- !!
- !! scalar
- !!
- IF( term1 .EQ. del_none ) THEN
- IF( term2 .EQ. del_x_all ) THEN
- CALL CM_5(ans=ans, test=test, trial=trial, c=c, &
- & term1=term1, term2=term2, opt=opt)
- ELSE
- CALL CM_3(ans=ans, test=test, trial=trial, c=c, &
- & term1=term2, term2=term2, opt=opt)
- END IF
+
+IF (term1 .EQ. del_none) THEN
+ IF (term2 .EQ. del_x_all) THEN
+ CALL CM_5(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt)
ELSE
- IF( term1 .EQ. del_x_all ) THEN
- CALL CM_6(ans=ans, test=test, trial=trial, c=c, &
- & term1=term1, term2=term2, opt=opt)
- ELSE
- CALL CM_4(ans=ans, test=test, trial=trial, c=c, &
- & term1=term2, term2=term2, opt=opt)
- END IF
+ CALL CM_3(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term2, term2=term2, opt=opt)
END IF
+ELSE
+ IF (term1 .EQ. del_x_all) THEN
+ CALL CM_6(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt)
+ ELSE
+ CALL CM_4(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term2, term2=term2, opt=opt)
+ END IF
+END IF
!!
END PROCEDURE ConvectiveMatrix_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ConvectiveMatrix2_
+
+IF (term1 .EQ. del_none) THEN
+ IF (term2 .EQ. del_x_all) THEN
+ CALL CM5_(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ ELSE
+ CALL CM3_(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ END IF
+ELSE
+ IF (term1 .EQ. del_x_all) THEN
+ CALL CM6_(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ ELSE
+ CALL CM4_(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term2, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ END IF
+END IF
+
+END PROCEDURE ConvectiveMatrix2_
+
!----------------------------------------------------------------------------
! ConvectiveMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE ConvectiveMatrix_3
!!
- IF( term1 .EQ. del_none ) THEN
- CALL CM_1(ans=ans, test=test, trial=trial, c=c, &
- & term1=term1, term2=term2, opt=opt)
- ELSE
- CALL CM_2(ans=ans, test=test, trial=trial, c=c, &
- & term1=term1, term2=term2, opt=opt)
- END IF
+IF (term1 .EQ. del_none) THEN
+ CALL CM_1(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt)
+ELSE
+ CALL CM_2(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt)
+END IF
!!
END PROCEDURE ConvectiveMatrix_3
@@ -134,4 +163,442 @@
!
!----------------------------------------------------------------------------
+MODULE PROCEDURE ConvectiveMatrix3_
+IF (term1 .EQ. del_none) THEN
+ CALL CM1_(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+ELSE
+ CALL CM2_(ans=ans, test=test, trial=trial, c=c, &
+ & term1=term1, term2=term2, opt=opt, nrow=nrow, ncol=ncol)
+END IF
+END PROCEDURE ConvectiveMatrix3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM1_(ans, test, trial, c, term1, term2, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ TYPE(FEVariable_), INTENT(IN) :: c
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj
+ REAL(DFP) :: p(trial%nns, trial%nips)
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+ REAL(DFP) :: realVal
+
+ nrow = test%nns
+ ncol = trial%nns
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+ CALL GetProjectionOfdNdXt_(obj=trial, cdNdXt=p, val=c, nrow=ii, ncol=jj)
+ !!
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=p(1:ncol, ips), &
+ nrow=ii, ncol=jj, ans=ans, &
+ scale=realval, anscoeff=one)
+ END DO
+
+ IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+ END IF
+
+END SUBROUTINE CM1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM2_(ans, test, trial, c, term1, term2, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ TYPE(FEVariable_), INTENT(IN) :: c
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj
+ REAL(DFP) :: p(test%nns, test%nips)
+ REAL(DFP) :: realval
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ nrow = test%nns
+ ncol = trial%nns
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+ CALL GetProjectionOfdNdXt_(obj=test, cdNdXt=p, val=c, nrow=ii, ncol=jj)
+
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ CALL OuterProd_(a=p(1:nrow, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=ii, ncol=jj, ans=ans, &
+ scale=realval, anscoeff=one)
+ END DO
+
+ IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+ END IF
+END SUBROUTINE CM2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM3_(ans, test, trial, term1, term2, c, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ TYPE(FEVariable_), INTENT(IN) :: c
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj
+ REAL(DFP) :: realval(trial%nips)
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ nrow = test%nns
+ ncol = trial%nns
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+ CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii)
+ realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii)
+
+ DO ips = 1, trial%nips
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%dNdXt(1:ncol, term2, ips), &
+ nrow=ii, ncol=jj, ans=ans, &
+ scale=realval(ips), anscoeff=one)
+ END DO
+
+ IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+ END IF
+END SUBROUTINE CM3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM4_(ans, test, trial, term1, term2, c, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ TYPE(FEVariable_), INTENT(IN) :: c
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj
+ REAL(DFP) :: realval(trial%nips)
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ nrow = SIZE(test%N, 1)
+ ncol = SIZE(trial%N, 1)
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+ CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii)
+ realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii)
+
+ DO ips = 1, trial%nips
+ CALL OuterProd_(a=test%dNdXt(1:nrow, term1, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=ii, ncol=jj, ans=ans, &
+ scale=realval(ips), anscoeff=one)
+ END DO
+
+ IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+ END IF
+END SUBROUTINE CM4_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM5_(ans, test, trial, term1, term2, c, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ TYPE(FEVariable_), INTENT(IN) :: c
+ INTEGER(I4B), INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj, kk, nsd
+ REAL(DFP) :: realval(trial%nips)
+ REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1)
+ REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd)
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii)
+ realval(1:trial%nips) = trial%js * trial%ws * trial%thickness * realval(1:trial%nips)
+
+ nrow = test%nns
+ ncol = trial%nns
+ nsd = trial%nsd
+
+ IF (opt .EQ. 1) THEN
+ m4_1 = 0.0_DFP
+ DO ips = 1, trial%nips
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%dNdXt(1:ncol, 1:nsd, ips), &
+ dim1=ii, dim2=jj, dim3=kk, &
+ ans=m4_1(1:nrow, 1:ncol, 1:nsd, 1), &
+ scale=realval(ips), anscoeff=one)
+ END DO
+ CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol)
+ ELSE
+ m4_2 = 0.0_DFP
+ DO ips = 1, trial%nips
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%dNdXt(1:ncol, 1:nsd, ips), &
+ dim1=ii, dim2=jj, dim3=kk, &
+ ans=m4_1(1:nrow, 1:ncol, 1, 1:nsd), &
+ scale=realval(ips), anscoeff=one)
+ END DO
+ CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol)
+ END IF
+
+END SUBROUTINE CM5_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM6_(ans, test, trial, term1, term2, c, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ TYPE(FEVariable_), INTENT(IN) :: c
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj, kk
+ REAL(DFP) :: realval(trial%nips)
+ REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1)
+ REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd)
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ nrow = test%nns
+ ncol = trial%nns
+
+ CALL GetInterpolation_(obj=trial, val=c, interpol=realval, tsize=ii)
+ realval(1:ii) = trial%js * trial%ws * trial%thickness * realval(1:ii)
+
+ IF (opt .EQ. 1) THEN
+ m4_1 = 0.0_DFP
+ DO ips = 1, trial%nips
+ DO ii = 1, trial%nsd
+ CALL OuterProd_(a=trial%dNdXt(1:nrow, ii, ips), &
+ b=test%N(1:ncol, ips), &
+ nrow=jj, ncol=kk, ans=m4_1(1:nrow, 1:ncol, ii, 1), &
+ scale=realval(ips), anscoeff=one)
+ END DO
+ END DO
+ CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol)
+ ELSE
+ m4_2 = 0.0_DFP
+ DO ips = 1, trial%nips
+ DO ii = 1, trial%nsd
+ CALL OuterProd_(a=trial%dNdXt(1:nrow, ii, ips), &
+ b=test%N(1:ncol, ips), &
+ nrow=jj, ncol=kk, ans=m4_2(1:nrow, 1:ncol, 1, ii), &
+ scale=realval(ips), anscoeff=one)
+ END DO
+ END DO
+ CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol)
+ END IF
+
+END SUBROUTINE CM6_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM7_(ans, test, trial, term1, term2, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj
+ REAL(DFP) :: realval
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ nrow = test%nns
+ ncol = trial%nns
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%dNdXt(1:ncol, term2, ips), &
+ nrow=ii, ncol=jj, ans=ans, &
+ scale=realval, anscoeff=one)
+ END DO
+
+ IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+ END IF
+
+END SUBROUTINE CM7_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM8_(ans, test, trial, term1, term2, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj
+ REAL(DFP) :: realval
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+ nrow = test%nns
+ ncol = trial%nns
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ CALL OuterProd_(a=test%dNdXt(1:nrow, term1, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=ii, ncol=jj, ans=ans, &
+ scale=realval, anscoeff=one)
+ END DO
+
+ IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+ END IF
+
+END SUBROUTINE CM8_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM9_(ans, test, trial, term1, term2, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj, kk
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+ REAL(DFP) :: realval
+ REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1)
+ REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd)
+
+ nrow = test%nns
+ ncol = trial%nns
+ IF (opt .EQ. 1) THEN
+ m4_1 = 0.0_DFP
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ DO ii = 1, trial%nsd
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%dNdXt(1:ncol, ii, ips), &
+ nrow=jj, ncol=kk, ans=m4_1(1:nrow, 1:ncol, ii, 1), &
+ scale=realval, anscoeff=one)
+ END DO
+ END DO
+ CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol)
+ ELSE
+ m4_2 = 0.0_DFP
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ DO ii = 1, trial%nsd
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%dNdXt(1:ncol, ii, ips), &
+ nrow=jj, ncol=kk, ans=m4_2(1:nrow, 1:ncol, 1, ii), &
+ scale=realval, anscoeff=one)
+ END DO
+ END DO
+ CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol)
+ END IF
+
+END SUBROUTINE CM9_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CM10_(ans, test, trial, term1, term2, opt, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ INTEGER(I4B), INTENT(IN) :: term1
+ INTEGER(I4B), INTENT(IN) :: term2
+ INTEGER(I4B), INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B) :: ips, ii, jj, kk
+ REAL(DFP), PARAMETER :: one = 1.0_DFP
+ REAL(DFP) :: realval
+ REAL(DFP) :: m4_1(test%nns, trial%nns, trial%nsd, 1)
+ REAL(DFP) :: m4_2(test%nns, trial%nns, 1, trial%nsd)
+
+ nrow = test%nns
+ ncol = trial%nns
+ IF (opt .EQ. 1) THEN
+ m4_1 = 0.0_DFP
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ DO ii = 1, trial%nsd
+ CALL OuterProd_(a=test%dNdXt(1:nrow, ii, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=jj, ncol=kk, ans=m4_1(1:nrow, 1:ncol, ii, 1), &
+ scale=realval, anscoeff=one)
+ END DO
+ END DO
+ CALL Convert_(from=m4_1, to=ans, nrow=nrow, ncol=ncol)
+ ELSE
+ m4_2 = 0.0_DFP
+ DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+ DO ii = 1, trial%nsd
+ CALL OuterProd_(a=test%dNdXt(1:nrow, ii, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=jj, ncol=kk, ans=m4_2(1:nrow, 1:ncol, 1, ii), &
+ scale=realval, anscoeff=one)
+ END DO
+ END DO
+ CALL Convert_(from=m4_2, to=ans, nrow=nrow, ncol=ncol)
+ END IF
+
+END SUBROUTINE CM10_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END SUBMODULE Methods
diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90
index 755daed8f..358c371d7 100644
--- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90
+++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90
@@ -25,186 +25,318 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_1
- REAL(DFP), ALLOCATABLE :: realval(:)
- INTEGER(I4B) :: ii
- !!
- !! main
- !!
- CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- realval = trial%js * trial%ws * trial%thickness
- DO ii = 1, SIZE(trial%N, 2)
- ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
- & TRANSPOSE(trial%dNdXt(:, :, ii)))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (realval)
- !!
+REAL(DFP), ALLOCATABLE :: realval(:)
+INTEGER(I4B) :: ii
+
+CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+realval = trial%js * trial%ws * trial%thickness
+DO ii = 1, SIZE(trial%N, 2)
+ ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
+ TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (realval)
END PROCEDURE DiffusionMatrix_1
+!----------------------------------------------------------------------------
+! DiffusionMatrix
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DiffusionMatrix1_
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+REAL(DFP) :: realval
+INTEGER(I4B) :: ii, jj, ips, dim
+
+nrow = test%nns
+ncol = trial%nns
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+
+ DO dim = 1, trial%nsd
+ CALL OuterProd_(a=test%dNdXt(1:nrow, dim, ips), &
+ b=trial%dNdXt(1:ncol, dim, ips), &
+ nrow=ii, ncol=jj, ans=ans, scale=realval, anscoeff=one)
+ END DO
+
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE DiffusionMatrix1_
+
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_2
- REAL(DFP), ALLOCATABLE :: realval(:), kbar(:)
- INTEGER(I4B) :: ii
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
- !!
- realval = trial%js * trial%ws * trial%thickness * kbar
- !!
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- !!
- DO ii = 1, SIZE(realval)
- !!
- ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
- & TRANSPOSE(trial%dNdXt(:, :, ii)))
- !!
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (kbar, realval)
+REAL(DFP), ALLOCATABLE :: realval(:), kbar(:)
+INTEGER(I4B) :: ii
+CALL GetInterpolation(obj=trial, Interpol=kbar, val=k)
+realval = trial%js * trial%ws * trial%thickness * kbar
+CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
+ TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (kbar, realval)
END PROCEDURE DiffusionMatrix_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DiffusionMatrix2_
+REAL(DFP) :: realval, kbar(trial%nips)
+INTEGER(I4B) :: ii
+
+CALL GetInterpolation_(obj=trial, Interpol=kbar, val=k, tsize=ii)
+nrow = test%nns
+ncol = trial%nns
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ii = 1, trial%nips
+ realval = trial%js(ii) * trial%ws(ii) * trial%thickness(ii) * kbar(ii)
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * MATMUL(test%dNdXt(:, :, ii), &
+ TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE DiffusionMatrix2_
+
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_3
- !!
- REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:)
- INTEGER(I4B) :: ii
- !!
- !! main
- !!
- CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k)
- CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k)
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- !!
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (c1bar, c2bar, realval)
- !!
+REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:)
+INTEGER(I4B) :: ii
+CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k)
+CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k)
+realval = trial%js * trial%ws * trial%thickness
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (c1bar, c2bar, realval)
END PROCEDURE DiffusionMatrix_3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DiffusionMatrix3_
+REAL(DFP) :: c1bar(test%nns, test%nips), c2bar(trial%nns, trial%nips)
+REAL(DFP) :: realval
+INTEGER(I4B) :: ii, jj, kk
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=k, nrow=nrow, ncol=ii)
+CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=k, nrow=ncol, ncol=ii)
+
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ii = 1, trial%nips
+ realval = trial%js(ii) * trial%ws(ii) * trial%thickness(ii)
+ CALL OuterProd_(a=c1bar(1:nrow, ii), b=c2bar(1:ncol, ii), &
+ nrow=jj, ncol=kk, ans=ans, &
+ scale=realval, anscoeff=one)
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+END PROCEDURE DiffusionMatrix3_
+
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_4
- ! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt)
- !! internal variable
- REAL(DFP), ALLOCATABLE :: kbar(:, :, :)
- REAL(DFP), ALLOCATABLE :: realval(:)
- INTEGER(I4B) :: ii
- !! main
- CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- !!
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * MATMUL(&
- & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), &
- & TRANSPOSE(trial%dNdXt(:, :, ii)))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (kbar, realval)
- !!
+! CALL DM_3(ans=ans, test=test, trial=trial, k=k, opt=opt)
+REAL(DFP), ALLOCATABLE :: kbar(:, :, :)
+REAL(DFP), ALLOCATABLE :: realval(:)
+INTEGER(I4B) :: ii
+CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
+realval = trial%js * trial%ws * trial%thickness
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * MATMUL(&
+ & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), &
+ & TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (kbar, realval)
END PROCEDURE DiffusionMatrix_4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DiffusionMatrix4_
+REAL(DFP) :: kbar(test%nsd, test%nsd, trial%nips)
+REAL(DFP) :: realval
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+INTEGER(I4B) :: ii, jj, kk
+
+CALL getInterpolation_(obj=trial, Interpol=kbar, val=k, &
+ dim1=ii, dim2=jj, dim3=kk)
+nrow = test%nns
+ncol = trial%nns
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ii = 1, trial%nips
+ realval = trial%js(ii) * trial%ws(ii) * trial%thickness(ii)
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * MATMUL(MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), &
+ TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE DiffusionMatrix4_
+
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_5
- !! scalar
- !! scalar
- !! CALL DM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
- REAL(DFP), ALLOCATABLE :: realval(:), cbar(:)
- INTEGER(I4B) :: ii
- !! main
- CALL getInterpolation(obj=trial, Interpol=cbar, val=c1)
- CALL getInterpolation(obj=trial, Interpol=realval, val=c2)
- realval = realval * trial%js * trial%ws * trial%thickness * cbar
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
- & TRANSPOSE(trial%dNdXt(:, :, ii)))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (cbar, realval)
+REAL(DFP), ALLOCATABLE :: realval(:), cbar(:)
+INTEGER(I4B) :: ii
+CALL getInterpolation(obj=trial, Interpol=cbar, val=c1)
+CALL getInterpolation(obj=trial, Interpol=realval, val=c2)
+realval = realval * trial%js * trial%ws * trial%thickness * cbar
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
+ & TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (cbar, realval)
END PROCEDURE DiffusionMatrix_5
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DiffusionMatrix5_
+REAL(DFP) :: realval(trial%nips), cbar(trial%nips)
+INTEGER(I4B) :: ii
+
+CALL getInterpolation_(obj=trial, Interpol=cbar, val=c1, tsize=ii)
+CALL getInterpolation_(obj=trial, Interpol=realval, val=c2, tsize=ii)
+realval = realval * trial%js * trial%ws * trial%thickness * cbar
+
+nrow = test%nns
+ncol = trial%nns
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ii = 1, trial%nips
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval(ii) * MATMUL(test%dNdXt(:, :, ii), &
+ TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE DiffusionMatrix5_
+
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_6
- !! scalar
- !! vector
- !! CALL DM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
- !!
- REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:)
- INTEGER(I4B) :: ii
- !! main
- CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2)
- CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2)
- CALL getInterpolation(obj=trial, interpol=realval, val=c1)
- realval = realval * trial%js * trial%ws * trial%thickness
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (c1bar, c2bar, realval)
- !!
+REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:)
+INTEGER(I4B) :: ii
+CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c2)
+CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2)
+CALL getInterpolation(obj=trial, interpol=realval, val=c1)
+realval = realval * trial%js * trial%ws * trial%thickness
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (c1bar, c2bar, realval)
END PROCEDURE DiffusionMatrix_6
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DiffusionMatrix6_
+REAL(DFP) :: c1bar(test%nns, test%nips), c2bar(trial%nns, trial%nips), &
+ realval(trial%nips)
+INTEGER(I4B) :: ii, jj, kk
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+CALL getProjectionOfdNdXt_(obj=test, cdNdXt=c1bar, val=c2, &
+ nrow=nrow, ncol=ii)
+CALL getProjectionOfdNdXt_(obj=trial, cdNdXt=c2bar, val=c2, &
+ nrow=ncol, ncol=ii)
+
+CALL getInterpolation_(obj=trial, interpol=realval, val=c1, &
+ tsize=ii)
+
+realval = realval * trial%js * trial%ws * trial%thickness
+
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ii = 1, trial%nips
+ CALL OuterProd_(a=c1bar(1:nrow, ii), b=c2bar(1:ncol, ii), &
+ nrow=jj, ncol=kk, ans=ans, &
+ scale=realval(ii), anscoeff=one)
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE DiffusionMatrix6_
+
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_7
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: kbar(:, :,:)
- INTEGER(I4B) :: ii
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, Interpol=realval, val=c1)
- CALL getInterpolation(obj=trial, Interpol=kbar, val=c2)
- realval = realval * trial%js * trial%ws * trial%thickness
- !!
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * MATMUL(&
- & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), &
- & TRANSPOSE(trial%dNdXt(:, :, ii)))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- DEALLOCATE(realval, kbar)
- !!
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: kbar(:, :, :)
+INTEGER(I4B) :: ii
+CALL getInterpolation(obj=trial, Interpol=realval, val=c1)
+CALL getInterpolation(obj=trial, Interpol=kbar, val=c2)
+realval = realval * trial%js * trial%ws * trial%thickness
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * MATMUL(&
+ & MATMUL(test%dNdXt(:, :, ii), kbar(:, :, ii)), &
+ & TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (realval, kbar)
END PROCEDURE DiffusionMatrix_7
!----------------------------------------------------------------------------
@@ -212,16 +344,14 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_8
- !!
- ans = DiffusionMatrix( &
- & test=test, &
- & trial=trial, &
- & c1=c2, &
- & c2=c1, &
- & c1rank=TypeFEVariableScalar, &
- & c2rank=TypeFEVariableVector, &
- & opt=opt)
- !!
+ans = DiffusionMatrix( &
+ & test=test, &
+ & trial=trial, &
+ & c1=c2, &
+ & c2=c1, &
+ & c1rank=TypeFEVariableScalar, &
+ & c2rank=TypeFEVariableVector, &
+ & opt=opt)
END PROCEDURE DiffusionMatrix_8
!----------------------------------------------------------------------------
@@ -229,24 +359,18 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_9
- !! Internal variable
- REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:)
- INTEGER(I4B) :: ii
- !!
+REAL(DFP), ALLOCATABLE :: c1bar(:, :), c2bar(:, :), realval(:)
+INTEGER(I4B) :: ii
!! main
- !!
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1)
- CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2)
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- DEALLOCATE (c1bar, c2bar, realval)
- !!
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=c1)
+CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=c2)
+realval = trial%js * trial%ws * trial%thickness
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (c1bar, c2bar, realval)
END PROCEDURE DiffusionMatrix_9
!----------------------------------------------------------------------------
@@ -254,35 +378,28 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_10
- !! internal variable
- REAL(DFP), ALLOCATABLE :: matbar(:, :, :)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :)
- REAL(DFP), ALLOCATABLE :: realval(:)
- TYPE(FEVariable_) :: k
- INTEGER(I4B) :: ii
- !! main
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=matbar, val=c2)
- CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3))
- !!
- DO ii = 1, SIZE(c2bar, 2)
- c1bar(:,ii) = MATMUL(c2bar(:,ii), matbar(:,:,ii))
- END DO
- !!
- k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace )
- CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k)
- CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k)
- realval = trial%js * trial%ws * trial%thickness
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (c1bar, c2bar, realval, matbar)
- !!
+REAL(DFP), ALLOCATABLE :: matbar(:, :, :)
+REAL(DFP), ALLOCATABLE :: c1bar(:, :)
+REAL(DFP), ALLOCATABLE :: c2bar(:, :)
+REAL(DFP), ALLOCATABLE :: realval(:)
+TYPE(FEVariable_) :: k
+INTEGER(I4B) :: ii
+CALL getInterpolation(obj=trial, interpol=c2bar, val=c1)
+CALL getInterpolation(obj=trial, interpol=matbar, val=c2)
+CALL Reallocate(c1bar, SIZE(matbar, 2), SIZE(matbar, 3))
+DO ii = 1, SIZE(c2bar, 2)
+ c1bar(:, ii) = MATMUL(c2bar(:, ii), matbar(:, :, ii))
+END DO
+k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace)
+CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k)
+CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k)
+realval = trial%js * trial%ws * trial%thickness
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (c1bar, c2bar, realval, matbar)
END PROCEDURE DiffusionMatrix_10
!----------------------------------------------------------------------------
@@ -290,15 +407,13 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_11
- !!
- ans = DiffusionMatrix( &
- & test=test, &
- & trial=trial, &
- & c1=c2, c2=c1, &
- & c1rank=TypeFEVariableScalar, &
- & c2rank=TypeFEVariableMatrix, &
- & opt=opt )
- !!
+ans = DiffusionMatrix( &
+ & test=test, &
+ & trial=trial, &
+ & c1=c2, c2=c1, &
+ & c1rank=TypeFEVariableScalar, &
+ & c2rank=TypeFEVariableMatrix, &
+ & opt=opt)
END PROCEDURE DiffusionMatrix_11
!----------------------------------------------------------------------------
@@ -306,34 +421,28 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_12
- !! internal variable
- REAL(DFP), ALLOCATABLE :: matbar(:, :, :)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :)
- REAL(DFP), ALLOCATABLE :: realval(:)
- TYPE(FEVariable_) :: k
- INTEGER(I4B) :: ii
- !! main
- CALL getInterpolation(obj=trial, interpol=matbar, val=c1)
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
- CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3))
- !!
- DO ii = 1, SIZE(c2bar, 2)
- c1bar(:,ii) = MATMUL(matbar(:,:,ii), c2bar(:,ii))
- END DO
- !!
- k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace )
- CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k)
- CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k)
- realval = trial%js * trial%ws * trial%thickness
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- DO ii = 1, SIZE(realval)
- ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (c1bar, c2bar, realval, matbar)
+REAL(DFP), ALLOCATABLE :: matbar(:, :, :)
+REAL(DFP), ALLOCATABLE :: c1bar(:, :)
+REAL(DFP), ALLOCATABLE :: c2bar(:, :)
+REAL(DFP), ALLOCATABLE :: realval(:)
+TYPE(FEVariable_) :: k
+INTEGER(I4B) :: ii
+CALL getInterpolation(obj=trial, interpol=matbar, val=c1)
+CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
+CALL Reallocate(c1bar, SIZE(matbar, 1), SIZE(matbar, 3))
+DO ii = 1, SIZE(c2bar, 2)
+ c1bar(:, ii) = MATMUL(matbar(:, :, ii), c2bar(:, ii))
+END DO
+k = QuadratureVariable(c1bar, typeFEVariableVector, typeFEVariableSpace)
+CALL getProjectionOfdNdXt(obj=test, cdNdXt=c1bar, val=k)
+CALL getProjectionOfdNdXt(obj=trial, cdNdXt=c2bar, val=k)
+realval = trial%js * trial%ws * trial%thickness
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * OUTERPROD(c1bar(:, ii), c2bar(:, ii))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (c1bar, c2bar, realval, matbar)
END PROCEDURE DiffusionMatrix_12
!----------------------------------------------------------------------------
@@ -341,26 +450,20 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_13
- !! internal variable
- REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:)
- INTEGER(I4B) :: ii
- !! main
- CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1)
- CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2)
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ii = 1, SIZE(realval)
- !!
- ans = ans + realval(ii) * MATMUL( &
- & MATMUL(test%dNdXt(:, :, ii),&
- & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), &
- & TRANSPOSE(trial%dNdXt(:, :, ii)))
- !!
- END DO
- !!
- IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
- DEALLOCATE (k1bar, k2bar, realval)
+REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:)
+INTEGER(I4B) :: ii
+CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1)
+CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2)
+CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
+realval = trial%js * trial%ws * trial%thickness
+DO ii = 1, SIZE(realval)
+ ans = ans + realval(ii) * MATMUL( &
+ & MATMUL(test%dNdXt(:, :, ii),&
+ & MATMUL(k1bar(:, :, ii), k2bar(:, :, ii))), &
+ & TRANSPOSE(trial%dNdXt(:, :, ii)))
+END DO
+IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
+DEALLOCATE (k1bar, k2bar, realval)
END PROCEDURE DiffusionMatrix_13
!----------------------------------------------------------------------------
@@ -368,82 +471,66 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_14
- !!
- SELECT CASE( opt(1) )
- CASE( 1 )
- CALL DiffusionMatrix_14a( test, trial, ans )
- CASE( 2 )
- CALL DiffusionMatrix_14b( test, trial, ans )
- END SELECT
- !!
+SELECT CASE (opt(1))
+CASE (1)
+ CALL DiffusionMatrix_14a(test, trial, ans)
+CASE (2)
+ CALL DiffusionMatrix_14b(test, trial, ans)
+END SELECT
END PROCEDURE DiffusionMatrix_14
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
-PURE SUBROUTINE DiffusionMatrix_14a( test, trial, ans )
- !!
+PURE SUBROUTINE DiffusionMatrix_14a(test, trial, ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
CLASS(ElemshapeData_), INTENT(IN) :: trial
- REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : )
- !!
- REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : )
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), ALLOCATABLE :: realval(:), m4(:, :, :, :)
INTEGER(I4B) :: ii, jj, nsd, ips
- !!
realval = trial%js * trial%ws * trial%thickness
- nsd = test%refelem%nsd
- CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd )
- !!
+ nsd = test%nsd
+ CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd)
DO ips = 1, SIZE(trial%N, 2)
DO jj = 1, nsd
DO ii = 1, nsd
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & test%dNdXt( :, ii, ips ), &
- & trial%dNdXt(:, jj, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & test%dNdXt(:, ii, ips), &
+ & trial%dNdXt(:, jj, ips))
END DO
END DO
END DO
- !!
- CALL Convert( from=m4, to=ans )
- !!
+ CALL Convert(from=m4, to=ans)
DEALLOCATE (realval, m4)
- !!
END SUBROUTINE DiffusionMatrix_14a
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
-PURE SUBROUTINE DiffusionMatrix_14b( test, trial, ans )
- !!
+PURE SUBROUTINE DiffusionMatrix_14b(test, trial, ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
CLASS(ElemshapeData_), INTENT(IN) :: trial
- REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : )
- !!
- REAL(DFP), ALLOCATABLE :: realval(:), m4( :, :, :, : )
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), ALLOCATABLE :: realval(:), m4(:, :, :, :)
INTEGER(I4B) :: ii, jj, nsd, ips
- !!
realval = trial%js * trial%ws * trial%thickness
- nsd = test%refelem%nsd
- CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd )
- !!
+ nsd = test%nsd
+ CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd)
DO ips = 1, SIZE(trial%N, 2)
DO jj = 1, nsd
DO ii = 1, nsd
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & test%dNdXt( :, jj, ips ), &
- & trial%dNdXt(:, ii, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & test%dNdXt(:, jj, ips), &
+ & trial%dNdXt(:, ii, ips))
END DO
END DO
END DO
- !!
- CALL Convert( from=m4, to=ans )
- !!
+ CALL Convert(from=m4, to=ans)
DEALLOCATE (realval, m4)
- !!
END SUBROUTINE DiffusionMatrix_14b
!----------------------------------------------------------------------------
@@ -451,98 +538,71 @@ END SUBROUTINE DiffusionMatrix_14b
!----------------------------------------------------------------------------
MODULE PROCEDURE DiffusionMatrix_15
- !!
- SELECT CASE( opt(1) )
- CASE( 1 )
- CALL DiffusionMatrix_15a( test, trial, k, ans )
- CASE( 2 )
- CALL DiffusionMatrix_15b( test, trial, k, ans )
- END SELECT
- !!
+SELECT CASE (opt(1))
+CASE (1)
+ CALL DiffusionMatrix_15a(test, trial, k, ans)
+CASE (2)
+ CALL DiffusionMatrix_15b(test, trial, k, ans)
+END SELECT
END PROCEDURE DiffusionMatrix_15
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
-PURE SUBROUTINE DiffusionMatrix_15a( test, trial, k, ans )
+PURE SUBROUTINE DiffusionMatrix_15a(test, trial, k, ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
- !! test function
CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! trial function
CLASS(FEVariable_), INTENT(IN) :: k
- !! scalar
- REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : )
- !!
- !! internal variables
- !!
- REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : )
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4(:, :, :, :)
INTEGER(I4B) :: ii, jj, nsd, ips
- !!
- !! main
- !!
- nsd = test%refelem%nsd
- CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd )
+ nsd = test%nsd
+ CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd)
CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
realval = trial%js * trial%ws * trial%thickness * kbar
- !!
DO ips = 1, SIZE(trial%N, 2)
DO jj = 1, nsd
DO ii = 1, nsd
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & test%dNdXt( :, ii, ips ), &
- & trial%dNdXt(:, jj, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & test%dNdXt(:, ii, ips), &
+ & trial%dNdXt(:, jj, ips))
END DO
END DO
END DO
- !!
- CALL Convert( from=m4, to=ans )
- !!
+ CALL Convert(from=m4, to=ans)
DEALLOCATE (kbar, realval, m4)
- !!
END SUBROUTINE DiffusionMatrix_15a
!----------------------------------------------------------------------------
! DiffusionMatrix
!----------------------------------------------------------------------------
-PURE SUBROUTINE DiffusionMatrix_15b( test, trial, k, ans )
+PURE SUBROUTINE DiffusionMatrix_15b(test, trial, k, ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
- !! test function
CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! trial function
CLASS(FEVariable_), INTENT(IN) :: k
- !! scalar
- REAL( DFP ), ALLOCATABLE, INTENT( INOUT ) :: ans( :, : )
- !!
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
!! internal variables
- !!
- REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4( :, :, :, : )
+ REAL(DFP), ALLOCATABLE :: realval(:), kbar(:), m4(:, :, :, :)
INTEGER(I4B) :: ii, jj, nsd, ips
- !!
- !! main
- !!
- nsd = test%refelem%nsd
- CALL Reallocate( m4, SIZE( test%N, 1 ), SIZE( trial%N, 1 ), nsd, nsd )
+ nsd = test%nsd
+ CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd)
CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
realval = trial%js * trial%ws * trial%thickness * kbar
- !!
DO ips = 1, SIZE(trial%N, 2)
DO jj = 1, nsd
DO ii = 1, nsd
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & test%dNdXt( :, jj, ips ), &
- & trial%dNdXt(:, ii, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & test%dNdXt(:, jj, ips), &
+ & trial%dNdXt(:, ii, ips))
END DO
END DO
END DO
- !!
- CALL Convert( from=m4, to=ans )
- !!
+ CALL Convert(from=m4, to=ans)
DEALLOCATE (kbar, realval, m4)
- !!
END SUBROUTINE DiffusionMatrix_15b
END SUBMODULE Methods
diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90
index 8a82a9b17..4d43bd2a3 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90
@@ -75,7 +75,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
ALLOCATE (ff(nns1, nsd * nns2), realval(nips))
realval = trial%Ws * trial%Js * trial%Thickness
ALLOCATE (ans(nns1 * nsd, nns2 * nsd)); ans = 0.0_DFP
@@ -124,7 +124,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
ALLOCATE (ff(nns1, nsd * nns2), realval(nips))
realval = trial%Ws * trial%Js * trial%Thickness
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
@@ -208,7 +208,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
ALLOCATE (ff(nns1, nsd * nns2), realval(nips))
realval = trial%Ws * trial%Js * trial%Thickness
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
@@ -256,7 +256,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
ALLOCATE (ff(nns1, nsd * nns2), realval(nips))
realval = trial%Ws * trial%Js * trial%Thickness
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90
index efb294ac2..8b9178127 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix2.F90
@@ -30,7 +30,7 @@
INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2
nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1)
-nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd
+nips = SIZE(trial%N, 2); nsd = trial%nsd
!<--- make integration parameters
realval = trial%Ws * trial%Thickness * trial%Js
!<--- allocate ans
@@ -74,7 +74,7 @@
INTEGER(I4B) :: nns1, nns2, nips, nsd, ips, r1, r2, i, j, c1, c2
nns1 = SIZE(test%N, 1); nns2 = SIZE(trial%N, 1)
-nips = SIZE(trial%N, 2); nsd = trial%refElem%nsd
+nips = SIZE(trial%N, 2); nsd = trial%nsd
SELECT CASE (lambda%VarType)
CASE (Constant)
diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90
index f18d33209..0424b6a0f 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90
@@ -58,7 +58,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
realval = trial%Ws * trial%Js * trial%Thickness * alpha
ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2))
ans = 0.0_DFP
@@ -99,7 +99,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
realval = trial%Ws * trial%Js * trial%Thickness * alpha
ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2))
ans = 0.0_DFP
@@ -140,7 +140,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
realval = trial%Ws * trial%Js * trial%Thickness * alpha
ALLOCATE (ans(nns1 * nsd, nns2 * nsd), dd(nns1, nns2))
ans = 0.0_DFP
@@ -191,7 +191,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
realval = trial%Ws * trial%Js * trial%Thickness * alpha
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
ans = 0.0_DFP
@@ -217,7 +217,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
realval = trial%Ws * trial%Js * trial%Thickness * alpha
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
ans = 0.0_DFP
diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90
index 73d82b6a7..3a5fb73d3 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixNormal.F90
@@ -33,7 +33,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
ALLOCATE (ff(nns1, nsd * nns2), realval(nips))
realval = trial%Ws * trial%Js * trial%Thickness
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
@@ -81,7 +81,7 @@
nns1 = SIZE(test%N, 1)
nns2 = SIZE(trial%N, 1)
nips = SIZE(trial%N, 2)
-nsd = trial%refElem%nsd
+nsd = trial%nsd
ALLOCATE (ff(nns1, nsd * nns2), realval(nips))
realval = trial%Ws * trial%Js * trial%Thickness
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt
index ca148d457..bc0b5a57d 100644
--- a/src/submodules/ElemshapeData/CMakeLists.txt
+++ b/src/submodules/ElemshapeData/CMakeLists.txt
@@ -1,63 +1,40 @@
-# This program is a part of EASIFEM library
-# Copyright (C) 2020-2021 Vikas Sharma, Ph.D
+# 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 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.
+# 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
+# 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}/ElemshapeData_ConstructorMethods@Methods.F90
- ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90
- ${src_path}/ElemshapeData_GetMethods@Methods.F90
- ${src_path}/ElemshapeData_GradientMethods@Methods.F90
-
- ${src_path}/H1/ElemshapeData_H1Methods@HermitMethods.F90
- ${src_path}/H1/ElemshapeData_H1Methods@HierarchyMethods.F90
- ${src_path}/H1/ElemshapeData_H1Methods@LagrangeMethods.F90
- ${src_path}/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90
- ${src_path}/H1/ElemshapeData_H1Methods@SerendipityMethods.F90
-
- ${src_path}/DG/ElemshapeData_DGMethods@HermitMethods.F90
- ${src_path}/DG/ElemshapeData_DGMethods@HierarchyMethods.F90
- ${src_path}/DG/ElemshapeData_DGMethods@LagrangeMethods.F90
- ${src_path}/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90
- ${src_path}/DG/ElemshapeData_DGMethods@SerendipityMethods.F90
-
- ${src_path}/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90
- ${src_path}/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90
- ${src_path}/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90
- ${src_path}/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90
- ${src_path}/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90
-
- ${src_path}/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90
- ${src_path}/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90
- ${src_path}/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90
- ${src_path}/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90
- ${src_path}/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90
-
- ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90
- ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90
- ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90
- ${src_path}/ElemshapeData_InterpolMethods@Methods.F90
- ${src_path}/ElemshapeData_IOMethods@Methods.F90
- ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90
- ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90
- ${src_path}/ElemshapeData_ProjectionMethods@Methods.F90
- ${src_path}/ElemshapeData_SetMethods@Methods.F90
- ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90
- ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90
- ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90
- ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90
-)
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ElemshapeData_ConstructorMethods@Methods.F90
+ ${src_path}/ElemshapeData_DivergenceMethods@Methods.F90
+ ${src_path}/ElemshapeData_GetMethods@Methods.F90
+ ${src_path}/ElemshapeData_GradientMethods@Methods.F90
+ ${src_path}/ElemshapeData_HminHmaxMethods@Methods.F90
+ ${src_path}/ElemshapeData_HRGNParamMethods@Methods.F90
+ ${src_path}/ElemshapeData_HRQIParamMethods@Methods.F90
+ ${src_path}/ElemshapeData_InterpolMethods@Methods.F90
+ ${src_path}/ElemshapeData_IOMethods@Methods.F90
+ ${src_path}/ElemshapeData_LocalDivergenceMethods@Methods.F90
+ ${src_path}/ElemshapeData_LocalGradientMethods@Methods.F90
+ ${src_path}/ElemshapeData_ProjectionMethods@Methods.F90
+ ${src_path}/ElemshapeData_SetMethods@Methods.F90
+ ${src_path}/ElemshapeData_StabilizationParamMethods@SUGN3.F90
+ ${src_path}/ElemshapeData_StabilizationParamMethods@SUPG.F90
+ ${src_path}/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90
+ ${src_path}/ElemshapeData_UnitNormalMethods@Methods.F90
+ ${src_path}/ElemshapeData_Lagrange@Methods.F90
+ ${src_path}/ElemshapeData_Hierarchical@Methods.F90
+ ${src_path}/ElemshapeData_Orthogonal@Methods.F90)
diff --git a/src/submodules/ElemshapeData/src/DG/CMakeLists.txt b/src/submodules/ElemshapeData/src/DG/CMakeLists.txt
new file mode 100644
index 000000000..1ca0cb2ca
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/DG/CMakeLists.txt
@@ -0,0 +1,25 @@
+# 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_path0 "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path0}/ElemshapeData_DGMethods@HermitMethods.F90
+ ${src_path0}/ElemshapeData_DGMethods@HierarchyMethods.F90
+ ${src_path0}/ElemshapeData_DGMethods@LagrangeMethods.F90
+ ${src_path0}/ElemshapeData_DGMethods@OrthogonalMethods.F90
+ ${src_path0}/ElemshapeData_DGMethods@SerendipityMethods.F90)
diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HermitMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HermitMethods.F90
rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HermitMethods.F90
diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HierarchyMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@HierarchyMethods.F90
rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@HierarchyMethods.F90
diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@LagrangeMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@LagrangeMethods.F90
rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@LagrangeMethods.F90
diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@OrthogonalMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@OrthogonalMethods.F90
rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@OrthogonalMethods.F90
diff --git a/src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@SerendipityMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/DG/ElemshapeData_DGMethods@SerendipityMethods.F90
rename to src/submodules/ElemshapeData/src/DG/src/ElemshapeData_DGMethods@SerendipityMethods.F90
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90
index 6c88af6d2..9c8f20e39 100755
--- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90
@@ -20,7 +20,12 @@
! summary: Constructor method for ElemshapeData_ and STElemshapeData_
SUBMODULE(ElemshapeData_ConstructorMethods) Methods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
+
+USE QuadraturePoint_Method, ONLY: GetQuadraturePoints
+
+USE ErrorHandling, ONLY: Errormsg
+
IMPLICIT NONE
CONTAINS
@@ -29,15 +34,37 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_Allocate
-CALL reallocate(obj%N, nns, nips)
-CALL reallocate(obj%dNdXi, nns, xidim, nips)
-CALL reallocate(obj%Normal, 3, nips)
-CALL reallocate(obj%dNdXt, nns, nsd, nips)
-CALL reallocate(obj%Jacobian, nsd, xidim, nips)
-CALL reallocate(obj%Js, nips)
-CALL reallocate(obj%Thickness, nips)
-obj%Thickness = 1.0_DFP
-CALL reallocate(obj%Coord, nsd, nips)
+LOGICAL(LGT) :: isok
+
+CALL Reallocate(obj%N, nns, nips)
+CALL Reallocate(obj%dNdXi, nns, xidim, nips)
+CALL Reallocate(obj%Normal, 3, nips)
+CALL Reallocate(obj%dNdXt, nns, nsd, nips)
+CALL Reallocate(obj%jacobian, nsd, xidim, nips)
+CALL Reallocate(obj%js, nips)
+CALL Reallocate(obj%thickness, nips)
+obj%thickness = 1.0_DFP
+CALL Reallocate(obj%coord, nsd, nips)
+CALL Reallocate(obj%ws, nips)
+obj%nsd = nsd
+obj%xidim = xidim
+obj%nips = nips
+obj%nns = nns
+
+isok = PRESENT(nnt)
+
+IF (isok) THEN
+ SELECT TYPE (obj); TYPE is (STElemShapeData_)
+ obj%nnt = nnt
+
+ CALL Reallocate(obj%T, nnt)
+ CALL Reallocate(obj%dTdTheta, nnt)
+ CALL Reallocate(obj%dNTdt, nns, nnt, nips)
+ CALL Reallocate(obj%dNTdXt, nns, nnt, nsd, nips)
+
+ END SELECT
+END IF
+
END PROCEDURE elemsd_Allocate
!----------------------------------------------------------------------------
@@ -53,262 +80,86 @@
& Line=__LINE__, &
& UnitNo=stdout)
STOP
-
-! SELECT CASE (TRIM(interpolType)//TRIM(continuityType))
-! CASE ("LagrangeInterpolation"//"H1")
-! CALL Initiate( &
-! & obj=obj, &
-! & quad=quad, &
-! & refElem=refElem, &
-! & continuityType=TypeH1, &
-! & interpolType=TypeLagrangeInterpolation)
-!
-! CASE ("LagrangeInterpolation"//"HDiv")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: LagrangeInterpolation &
-! & BaseContinuityType: HDiv", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("LagrangeInterpolation"//"HCurl")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: LagrangeInterpolation &
-! & BaseContinuityType: HCurl", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("LagrangeInterpolation"//"DG")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: LagrangeInterpolation &
-! & BaseContinuityType: DG", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HermitInterpolation"//"H1")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HermitInterpolation &
-! & BaseContinuityType: H1", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HermitInterpolation"//"HDiv")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HermitInterpolation &
-! & BaseContinuityType: HDiv", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HermitInterpolation"//"HCurl")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HermitInterpolation &
-! & BaseContinuityType: HCurl", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HermitInterpolation"//"DG")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HermitInterpolation &
-! & BaseContinuityType: DG", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("SerendipityInterpolation"//"H1")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: SerendipityInterpolation &
-! & BaseContinuityType: H1", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("SerendipityInterpolation"//"HDiv")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: SerendipityInterpolation &
-! & BaseContinuityType: HDiv", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("SerendipityInterpolation"//"HCurl")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: SerendipityInterpolation &
-! & BaseContinuityType: HCurl", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("SerendipityInterpolation"//"DG")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: SerendipityInterpolation &
-! & BaseContinuityType: DG", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HierarchyInterpolation"//"H1")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HierarchyInterpolation &
-! & BaseContinuityType: H1", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HierarchyInterpolation"//"HDiv")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HierarchyInterpolation &
-! & BaseContinuityType: HDiv", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HierarchyInterpolation"//"HCurl")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HierarchyInterpolation &
-! & BaseContinuityType: HCurl", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE ("HierarchyInterpolation"//"DG")
-! CALL ErrorMSG( &
-! & Msg="BaseInterpolation: HierarchyInterpolation &
-! & BaseContinuityType: DG", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! STOP
-!
-! CASE DEFAULT
-! CALL ErrorMSG( &
-! & Msg="Unknown child name of BaseInterpolation &
-! & and BaseContinuityType", &
-! & File="ElemshapeData_Method@Constructor.F90", &
-! & Routine="elemsd_Initiate1()", &
-! & Line=__LINE__, &
-! & UnitNo=stdout)
-! END SELECT
-
END PROCEDURE elemsd_Initiate1
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_initiate2
-IF (ALLOCATED(obj2%N)) obj1%N = obj2%N
-IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi
-IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian
-IF (ALLOCATED(obj2%js)) obj1%js = obj2%js
-IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws
-IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt
-IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness
-IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord
-IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal
-obj1%refElem = obj2%refElem
-END PROCEDURE elemsd_initiate2
+MODULE PROCEDURE elemsd_Initiate2
+INTEGER(I4B) :: ii, jj, kk, nns, nsd, xidim, nips, nnt, ll, nnt
-!----------------------------------------------------------------------------
-! Initiate
-!----------------------------------------------------------------------------
+nns = obj2%nns
+nsd = obj2%nsd
+xidim = obj2%xidim
+nips = obj2%nips
-MODULE PROCEDURE elemsd_initiate3
-IF (ALLOCATED(obj2%N)) obj1%N = obj2%N
-IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi
-IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian
-IF (ALLOCATED(obj2%js)) obj1%js = obj2%js
-IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws
-IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt
-IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness
-IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord
-IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal
-obj1%refElem = obj2%refElem
-END PROCEDURE elemsd_initiate3
+SELECT TYPE (obj2); TYPE is (STElemShapeData_)
+ nnt = obj2%nnt
+END SELECT
-!----------------------------------------------------------------------------
-! Initiate
-!----------------------------------------------------------------------------
+CALL elemsd_Allocate(obj=obj1, nsd=nsd, xidim=xidim, nns=nns, &
+ nips=nips, nnt=nnt)
-MODULE PROCEDURE elemsd_initiate4
-IF (ALLOCATED(obj2%N)) obj1%N = obj2%N
-IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi
-IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian
-IF (ALLOCATED(obj2%js)) obj1%js = obj2%js
-IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws
-IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt
-IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness
-IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord
-IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal
-obj1%refElem = obj2%refElem
-END PROCEDURE elemsd_initiate4
+DO CONCURRENT(jj=1:nips, ii=1:nns)
+ obj1%N(ii, jj) = obj2%N(ii, jj)
+END DO
-!----------------------------------------------------------------------------
-! Initiate
-!----------------------------------------------------------------------------
+DO CONCURRENT(kk=1:nips, jj=1:xidim, ii=1:nns)
+ obj1%dNdXi(ii, jj, kk) = obj2%dNdXi(ii, jj, kk)
+END DO
+
+DO CONCURRENT(kk=1:nips, jj=1:nsd, ii=1:nns)
+ obj1%dNdXt(ii, jj, kk) = obj2%dNdXt(ii, jj, kk)
+END DO
+
+DO CONCURRENT(ii=1:nsd, jj=1:xidim, kk=1:nips)
+ obj1%jacobian(ii, jj, kk) = obj2%jacobian(ii, jj, kk)
+END DO
+
+DO CONCURRENT(ii=1:nips)
+ obj1%js(ii) = obj2%js(ii)
+ obj1%ws(ii) = obj2%ws(ii)
+ obj1%thickness(ii) = obj2%thickness(ii)
+ obj1%coord(1:nsd, ii) = obj2%coord(1:nsd, ii)
+ obj1%normal(1:3, ii) = obj2%normal(1:3, ii)
+END DO
+
+SELECT TYPE (obj1); TYPE is (STElemShapeData_)
+ SELECT TYPE (obj2); TYPE is (STElemShapeData_)
+ obj1%wt = obj2%wt
+! obj1%theta = obj2%theta
+ obj1%jt = obj2%jt
+ obj1%nnt = obj2%nnt
+ nnt = obj1%nnt
+
+ DO CONCURRENT(ii=1:nnt)
+ obj1%T(ii) = obj2%T(ii)
+ obj1%dTdTheta(ii) = obj2%dTdTheta(ii)
+ END DO
+
+ DO CONCURRENT(ii=1:nns, jj=1:nnt, kk=1:nips)
+ obj1%dNTdt(ii, jj, kk) = obj2%dNTdt(ii, jj, kk)
+ END DO
+
+ DO CONCURRENT(ii=1:nns, jj=1:nnt, kk=1:nsd, ll=1:nips)
+ obj1%dNTdXt(ii, jj, kk, ll) = obj2%dNTdXt(ii, jj, kk, ll)
+ END DO
+
+ END SELECT
+END SELECT
-MODULE PROCEDURE elemsd_initiate5
-IF (ALLOCATED(obj2%N)) obj1%N = obj2%N
-IF (ALLOCATED(obj2%dNdXi)) obj1%dNdXi = obj2%dNdXi
-IF (ALLOCATED(obj2%jacobian)) obj1%jacobian = obj2%jacobian
-IF (ALLOCATED(obj2%js)) obj1%js = obj2%js
-IF (ALLOCATED(obj2%ws)) obj1%ws = obj2%ws
-IF (ALLOCATED(obj2%dNdXt)) obj1%dNdXt = obj2%dNdXt
-IF (ALLOCATED(obj2%thickness)) obj1%thickness = obj2%thickness
-IF (ALLOCATED(obj2%coord)) obj1%coord = obj2%coord
-IF (ALLOCATED(obj2%normal)) obj1%normal = obj2%normal
-obj1%refElem = obj2%refElem
-obj1%wt = obj2%wt
-obj1%theta = obj2%theta
-obj1%jt = obj2%jt
-IF (ALLOCATED(obj2%T)) obj1%T = obj2%T
-IF (ALLOCATED(obj2%dTdTheta)) obj1%dTdTheta = obj2%dTdTheta
-IF (ALLOCATED(obj2%dNTdt)) obj1%dNTdt = obj2%dNTdt
-IF (ALLOCATED(obj2%dNTdXt)) obj1%dNTdXt = obj2%dNTdXt
-END PROCEDURE elemsd_initiate5
+END PROCEDURE elemsd_Initiate2
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE stsd_initiate
-INTEGER(I4B) :: tip, ip
-REAL(DFP) :: x(3)
+MODULE PROCEDURE stsd_Initiate
+INTEGER(I4B) :: tip, ip, nnt
+
+tip = elemsd%nips
-tip = SIZE(elemsd%N, 2)
IF (ALLOCATED(obj)) THEN
DO ip = 1, SIZE(obj)
CALL DEALLOCATE (obj(ip))
@@ -317,37 +168,49 @@
END IF
ALLOCATE (obj(tip))
+
+nnt = elemsd%nns
+
DO ip = 1, tip
- obj(ip)%T = elemsd%N(:, ip)
- obj(ip)%dTdTheta = elemsd%dNdXi(:, 1, ip)
- obj(ip)%Jt = elemsd%Js(ip)
- CALL getQuadraturePoints( &
- & obj=elemsd%quad, &
- & weights=obj(ip)%wt,&
- & points=x, &
- & num=ip)
- obj(ip)%theta = x(1)
+ obj(ip)%jt = elemsd%js(ip)
+ obj(ip)%wt = elemsd%ws(ip)
+ obj(ip)%nnt = nnt
+
+ CALL Reallocate(obj(ip)%T, nnt)
+ obj(ip)%T(1:nnt) = elemsd%N(1:nnt, ip)
+
+ CALL Reallocate(obj(ip)%dTdTheta, nnt)
+ obj(ip)%dTdTheta(1:nnt) = elemsd%dNdXi(1:nnt, 1, ip)
END DO
-END PROCEDURE stsd_initiate
+
+END PROCEDURE stsd_Initiate
!----------------------------------------------------------------------------
! Deallocate
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_Deallocate
-IF (ALLOCATED(obj%Normal)) DEALLOCATE (obj%Normal)
+IF (ALLOCATED(obj%normal)) DEALLOCATE (obj%normal)
IF (ALLOCATED(obj%N)) DEALLOCATE (obj%N)
IF (ALLOCATED(obj%dNdXi)) DEALLOCATE (obj%dNdXi)
IF (ALLOCATED(obj%dNdXt)) DEALLOCATE (obj%dNdXt)
-IF (ALLOCATED(obj%Jacobian)) DEALLOCATE (obj%Jacobian)
-IF (ALLOCATED(obj%Js)) DEALLOCATE (obj%Js)
-IF (ALLOCATED(obj%Ws)) DEALLOCATE (obj%Ws)
-IF (ALLOCATED(obj%Thickness)) DEALLOCATE (obj%Thickness)
-IF (ALLOCATED(obj%Coord)) DEALLOCATE (obj%Coord)
-CALL DEALLOCATE (obj%Quad)
-CALL DEALLOCATE (obj%refelem)
+IF (ALLOCATED(obj%jacobian)) DEALLOCATE (obj%jacobian)
+IF (ALLOCATED(obj%js)) DEALLOCATE (obj%js)
+IF (ALLOCATED(obj%ws)) DEALLOCATE (obj%ws)
+IF (ALLOCATED(obj%thickness)) DEALLOCATE (obj%thickness)
+IF (ALLOCATED(obj%coord)) DEALLOCATE (obj%coord)
+
+obj%nsd = 0
+obj%xidim = 0
+obj%nips = 0
+obj%nns = 0
+! CALL DEALLOCATE (obj%Quad)
+! CALL DEALLOCATE (obj%refelem)
SELECT TYPE (obj)
TYPE IS (STElemShapeData_)
+ obj%nnt = 0
+ obj%wt = 0
+ obj%jt = 0
IF (ALLOCATED(obj%T)) DEALLOCATE (obj%T)
IF (ALLOCATED(obj%dTdTheta)) DEALLOCATE (obj%dTdTheta)
IF (ALLOCATED(obj%dNTdt)) DEALLOCATE (obj%dNTdt)
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90
index 7f245d9b9..29ff85e9c 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_DivergenceMethods@Methods.F90
@@ -16,178 +16,272 @@
!
SUBMODULE(ElemshapeData_DivergenceMethods) Methods
-USE BaseMethod
+USE ContractionUtility, ONLY: Contraction
+
+USE SwapUtility, ONLY: Swap
+
+USE ReallocateUtility, ONLY: Reallocate
+
+USE FEVariable_Method, ONLY: QuadratureVariable, NodalVariable, shape, Get
+
+USE Basetype, ONLY: TypeFEVariableOpt, TypeFEVariableScalar, &
+ TypeFEVariableVector, TypeFEVariableMatrix, TypeFEVariableConstant, &
+ TypeFEVariableSpace, TypeFEVariableTime, TypeFEVariableSpaceTime
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_1
-lg = Contraction(a1=TRANSPOSE(val), a2=obj%dNdXt)
-END PROCEDURE elemsd_getDivergence_1
+MODULE PROCEDURE elemsd_GetDivergence_1
+INTEGER(I4B) :: ii, jj, ips
+
+tsize = obj%nips
+
+DO ips = 1, tsize
+ ans(ips) = 0.0_DFP
+
+ DO jj = 1, obj%nns
+ DO ii = 1, obj%nsd
+ ans(ips) = ans(ips) + val(ii, jj) * obj%dNdXt(jj, ii, ips)
+ END DO
+ END DO
+END DO
+
+END PROCEDURE elemsd_GetDivergence_1
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_2
-REAL(DFP), ALLOCATABLE :: r3(:, :, :)
-!! main
-SELECT TYPE (obj)
-TYPE IS (STElemshapeData_)
- CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1)
- lg = Contraction(r3, obj%dNTdXt)
- DEALLOCATE (r3)
+MODULE PROCEDURE elemsd_GetDivergence_2
+INTEGER(I4B) :: ips, I, ii, a, ips
+
+tsize = obj%nips
+
+SELECT TYPE (obj); TYPE is (STElemShapeData_)
+
+ DO ips = 1, tsize
+ ans(ips) = 0.0_DFP
+
+ DO a = 1, obj%nnt
+ DO I = 1, obj%nns
+ DO ii = 1, obj%nsd
+ ans(ips) = ans(ips) + val(ii, I, a) * obj%dNTdXt(I, a, ii, ips)
+ END DO
+ END DO
+ END DO
+
+ END DO
+
END SELECT
-END PROCEDURE elemsd_getDivergence_2
+
+END PROCEDURE elemsd_GetDivergence_2
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_3
+MODULE PROCEDURE elemsd_GetDivergence_3
+tsize = obj%nips
+
SELECT CASE (val%varType)
-CASE (constant)
- CALL reallocate(lg, SIZE(obj%N, 2))
-CASE (space)
- CALL getDivergence(obj=obj, lg=lg, &
- & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace))
-CASE (spacetime)
- SELECT TYPE (obj)
- TYPE is (STElemShapeData_)
- CALL getDivergence(obj=obj, lg=lg, &
- & Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime))
+CASE (TypeFEVariableOpt%constant)
+ ! CALL Reallocate(lg, SIZE(obj%N, 2))
+ ans(1:tsize) = 0.0
+
+CASE (TypeFEVariableOpt%space)
+ CALL GetDivergence(obj=obj, ans=ans, tsize=tsize, &
+ Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace))
+
+CASE (TypeFEVariableOpt%spacetime)
+
+ SELECT TYPE (obj); TYPE is (STElemShapeData_)
+
+ CALL GetDivergence(obj=obj, ans=ans, tsize=tsize, &
+ Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime))
END SELECT
+
END SELECT
-END PROCEDURE elemsd_getDivergence_3
+END PROCEDURE elemsd_GetDivergence_3
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_4
-INTEGER(I4B) :: ii, n
-!!
-n = SIZE(obj%N, 2)
-CALL reallocate(lg, SIZE(val, 1), n)
-DO ii = 1, n
- lg(:, ii) = contraction(val, TRANSPOSE(obj%dNdXt(:, :, ii)))
+MODULE PROCEDURE elemsd_GetDivergence_4
+INTEGER(I4B) :: ii, jj, ips, I
+
+nrow = SIZE(val, 1)
+ncol = obj%nips
+
+DO ips = 1, ncol
+ DO jj = 1, nrow
+
+ ans(jj, ips) = 0.0_DFP
+
+ DO I = 1, obj%nns
+ DO ii = 1, obj%nsd
+ ans(jj, ips) = ans(jj, ips) + val(ii, jj, I) * obj%dNdXt(I, ii, ips)
+ END DO
+ END DO
+ END DO
END DO
-END PROCEDURE elemsd_getDivergence_4
+
+END PROCEDURE elemsd_GetDivergence_4
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_5
-REAL(DFP), ALLOCATABLE :: r4(:, :, :, :)
-INTEGER(I4B) :: ii
-!!
-SELECT TYPE (obj)
-TYPE IS (STElemShapeData_)
- CALL SWAP(a=r4, b=val, i1=3, i2=4, i3=2, i4=1)
- CALL Reallocate(lg, size(obj%N, 2), size(val, 1))
- DO ii = 1, SIZE(r4, 4)
- lg(:, ii) = Contraction(a1=r4(:, :, :, ii), a2=obj%dNTdXt)
+MODULE PROCEDURE elemsd_GetDivergence_5
+INTEGER(I4B) :: ii, jj, ips, I, a
+
+nrow = SIZE(val, 1)
+ncol = obj%nips
+
+SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+
+ DO ips = 1, ncol
+ DO jj = 1, nrow
+
+ ans(jj, ips) = 0.0_DFP
+
+ DO a = 1, obj%nnt
+ DO I = 1, obj%nns
+ DO ii = 1, obj%nsd
+ ans(jj, ips) = ans(jj, ips) + &
+ val(ii, jj, I, a) * obj%dNTdXt(I, a, ii, ips)
+ END DO
+ END DO
+ END DO
+ END DO
END DO
- lg = TRANSPOSE(lg)
- Deallocate (r4)
+
END SELECT
-!!
-END PROCEDURE elemsd_getDivergence_5
+
+END PROCEDURE elemsd_GetDivergence_5
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_6
+MODULE PROCEDURE elemsd_GetDivergence_6
INTEGER(I4B) :: s(2)
-!!
+
SELECT CASE (val%varType)
-CASE (constant)
+
+CASE (TypeFEVariableOpt%constant)
s = SHAPE(val)
- CALL reallocate(lg, s(1), SIZE(obj%N, 2))
-CASE (space)
- CALL getDivergence(obj=obj, lg=lg, &
- & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace))
-CASE (spacetime)
- SELECT TYPE (obj)
- TYPE is (STElemShapeData_)
- CALL getDivergence(obj=obj, lg=lg, &
- & Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime))
+ ! CALL Reallocate(lg, s(1), SIZE(obj%N, 2))
+ nrow = s(1)
+ ncol = obj%nips
+ ans(1:nrow, 1:ncol) = 0.0
+
+CASE (TypeFEVariableOpt%space)
+ CALL GetDivergence(obj=obj, ans=ans, nrow=nrow, ncol=ncol, &
+ Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace))
+
+CASE (TypeFEVariableOpt%spacetime)
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+
+ CALL GetDivergence(obj=obj, ans=ans, nrow=nrow, ncol=ncol, &
+ Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime))
+
END SELECT
+
END SELECT
-END PROCEDURE elemsd_getDivergence_6
+END PROCEDURE elemsd_GetDivergence_6
!----------------------------------------------------------------------------
-! getDivergence
+! GetDivergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_7
+MODULE PROCEDURE elemsd_GetDivergence_7
REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :)
-!!
+INTEGER(I4B) :: ii, jj, s(2)
+
SELECT CASE (val%rank)
-CASE (vector)
- CALL getDivergence(obj=obj, lg=r1, val=val)
- lg = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace)
+
+CASE (TypeFEVariableOpt%vector)
+ ALLOCATE (r1(obj%nips))
+ CALL GetDivergence(obj=obj, ans=r1, val=val, tsize=ii)
+ ans = QuadratureVariable(r1, typeFEVariableScalar, typeFEVariableSpace)
DEALLOCATE (r1)
-CASE (matrix)
- CALL getDivergence(obj=obj, lg=r2, val=val)
- lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+
+CASE (TypeFEVariableOpt%matrix)
+ s = SHAPE(val)
+ ALLOCATE (r2(s(1), obj%nips))
+ CALL GetDivergence(obj=obj, ans=r2, val=val, nrow=ii, ncol=jj)
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
DEALLOCATE (r2)
+
END SELECT
-END PROCEDURE elemsd_getDivergence_7
+END PROCEDURE elemsd_GetDivergence_7
!----------------------------------------------------------------------------
! Divergence
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getDivergence_8
+MODULE PROCEDURE elemsd_GetDivergence_8
REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :)
-INTEGER(I4B) :: ii
-!!
+INTEGER(I4B) :: ii, nipt, jj, kk, s(2)
+
+nipt = SIZE(obj)
+
SELECT CASE (val%rank)
-!!
-!! vector
-!!
-CASE (vector)
- DO ii = 1, SIZE(obj)
- CALL getDivergence(obj=obj(ii), lg=r1, val=val)
- IF (.NOT. ALLOCATED(r2)) THEN
- CALL reallocate(r2, SIZE(r1, 1), SIZE(obj))
- END IF
- !!
- r2(:, ii) = r1
+
+CASE (TypeFEVariableOpt%vector)
+
+ ii = 0
+ DO jj = 1, nipt
+ IF (obj(jj)%nips .GT. ii) ii = obj(jj)%nips
END DO
- lg = QuadratureVariable(r2, typeFEVariableScalar,&
- & typeFEVariableSpaceTime)
+
+ ALLOCATE (r1(ii), r2(ii, nipt))
+
+ DO ii = 1, nipt
+ CALL GetDivergence(obj=obj(ii), ans=r1(1:obj(ii)%nips), val=val, tsize=jj)
+ r2(1:obj(ii)%nips, ii) = r1(1:obj(ii)%nips)
+ END DO
+
+ ans = QuadratureVariable(r2(1:obj(ii)%nips, 1:nipt), typeFEVariableScalar, &
+ typeFEVariableSpaceTime)
DEALLOCATE (r2, r1)
-!!
-!! matrix
-!!
-CASE (matrix)
- DO ii = 1, SIZE(obj)
- CALL getDivergence(obj=obj(ii), lg=r2, val=val)
- IF (.NOT. ALLOCATED(r3)) THEN
- CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj))
- END IF
- !!
- r3(:, :, ii) = r2
+
+CASE (TypeFEVariableOpt%matrix)
+
+ nipt = SIZE(obj)
+
+ ii = 0
+ DO jj = 1, nipt
+ IF (obj(jj)%nips .GT. ii) ii = obj(jj)%nips
+ END DO
+
+ s = SHAPE(val)
+ kk = s(1)
+
+ ALLOCATE (r2(kk, ii), r3(kk, ii, nipt))
+
+ DO ii = 1, nipt
+ CALL GetDivergence(obj=obj(ii), ans=r2, val=val, nrow=jj, ncol=kk)
+ r3(1:jj, 1:kk, ii) = r2(1:jj, 1:kk)
END DO
- lg = QuadratureVariable(r3, typeFEVariableVector,&
- & typeFEVariableSpaceTime)
+
+ ans = QuadratureVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime)
DEALLOCATE (r2, r3)
END SELECT
-END PROCEDURE elemsd_getDivergence_8
+END PROCEDURE elemsd_GetDivergence_8
!----------------------------------------------------------------------------
! Divergence
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_Divergence_1
-CALL getDivergence(obj=obj, lg=ans, val=val)
+CALL GetDivergence(obj=obj, ans=ans, val=val)
END PROCEDURE elemsd_Divergence_1
!----------------------------------------------------------------------------
@@ -195,7 +289,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_Divergence_2
-CALL getDivergence(obj=obj, lg=ans, val=val)
+CALL GetDivergence(obj=obj, ans=ans, val=val)
END PROCEDURE elemsd_Divergence_2
!----------------------------------------------------------------------------
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90
index 15a59dba9..e4c61a46e 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_GetMethods@Methods.F90
@@ -16,7 +16,14 @@
!
SUBMODULE(ElemshapeData_GetMethods) Methods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
+
+USE FEVariable_Method, ONLY: QuadratureVariable, NodalVariable
+
+USE BaseType, ONLY: TypeFEVariableSpace, &
+ TypeFEVariableVector, &
+ TypeFEVariableSpaceTime
+
IMPLICIT NONE
CONTAINS
@@ -26,9 +33,11 @@
MODULE PROCEDURE elemsd_getnormal_1
IF (PRESENT(nsd)) THEN
- normal = obj%normal(1:nsd, :)
+ CALL Reallocate(normal, nsd, obj%nips)
+ normal(1:nsd, 1:obj%nips) = obj%normal(1:nsd, 1:obj%nips)
ELSE
- normal = obj%normal
+ CALL Reallocate(normal, 3, obj%nips)
+ normal(1:3, 1:obj%nips) = obj%normal(1:3, 1:obj%nips)
END IF
END PROCEDURE elemsd_GetNormal_1
@@ -38,13 +47,13 @@
MODULE PROCEDURE elemsd_getnormal_2
IF (PRESENT(nsd)) THEN
- normal = QuadratureVariable(obj%normal(1:nsd, :), &
- & TypeFEVariableVector, &
- & TypeFEVariableSpace)
+ normal = QuadratureVariable(obj%normal(1:nsd, 1:obj%nips), &
+ TypeFEVariableVector, &
+ TypeFEVariableSpace)
ELSE
- normal = QuadratureVariable(obj%normal, &
- & TypeFEVariableVector, &
- & TypeFEVariableSpace)
+ normal = QuadratureVariable(obj%normal(1:3, 1:obj%nips), &
+ TypeFEVariableVector, &
+ TypeFEVariableSpace)
END IF
END PROCEDURE elemsd_getnormal_2
@@ -53,39 +62,28 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_getnormal_3
- !!
REAL(DFP), ALLOCATABLE :: m3(:, :, :)
-INTEGER(I4B) :: ii
- !!
-IF (PRESENT(nsd)) THEN
- !!
- CALL Reallocate(m3, &
- & nsd, &
- & SIZE(obj(1)%normal, 2), &
- & SIZE(obj))
- !!
- DO ii = 1, SIZE(obj)
- m3(1:nsd, :, ii) = obj(ii)%normal(1:nsd, :)
- END DO
- !!
-ELSE
- !!
- CALL Reallocate(m3, &
- & SIZE(obj(1)%normal, 1), &
- & SIZE(obj(1)%normal, 2), &
- & SIZE(obj))
- !!
- DO ii = 1, SIZE(obj)
- m3(:, :, ii) = obj(ii)%normal
- END DO
- !!
-END IF
- !!
+INTEGER(I4B) :: ii, nips, nipt, nsd0
+
+nipt = SIZE(obj)
+nips = 0
+DO ii = 1, nipt
+ IF (obj(ii)%nips > nips) nips = obj(ii)%nips
+END DO
+
+nsd0 = 3
+IF (PRESENT(nsd)) nsd0 = nsd
+
+ALLOCATE (m3(nsd0, nips, nipt))
+
+DO ii = 1, nipt
+ m3(1:nsd0, 1:obj(ii)%nips, ii) = obj(ii)%normal(1:nsd0, 1:obj(ii)%nips)
+END DO
+
normal = QuadratureVariable(m3, TypeFEVariableVector, &
- & TypeFEVariableSpaceTime)
- !!
+ TypeFEVariableSpaceTime)
+
DEALLOCATE (m3)
- !!
END PROCEDURE elemsd_getnormal_3
!----------------------------------------------------------------------------
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90
index 62717e546..cffae78a7 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_GradientMethods@Methods.F90
@@ -17,145 +17,142 @@
SUBMODULE(ElemshapeData_GradientMethods) Methods
USE BaseMethod
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_1
-IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN
+MODULE PROCEDURE elemsd_GetSpatialGradient_1
+IF (obj%nsd .EQ. obj%xidim) THEN
lg = MATMUL(Val, obj%dNdXt)
ELSE
- CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2))
+ CALL Reallocate(lg, obj%nsd, obj%nips)
END IF
-END PROCEDURE elemsd_getSpatialGradient_1
+END PROCEDURE elemsd_GetSpatialGradient_1
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_2
-IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN
+MODULE PROCEDURE elemsd_GetSpatialGradient_2
+IF (obj%nsd .EQ. obj%xidim) THEN
lg = MATMUL(Val, obj%dNdXt)
ELSE
- CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, &
- & SIZE(obj%N, 2))
+ CALL Reallocate(lg, SIZE(val, 1), obj%nsd, obj%nips)
END IF
-END PROCEDURE elemsd_getSpatialGradient_2
+END PROCEDURE elemsd_GetSpatialGradient_2
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_3
+MODULE PROCEDURE elemsd_GetSpatialGradient_3
SELECT TYPE (obj)
TYPE IS (STElemshapeData_)
- IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN
+ IF (obj%nsd .EQ. obj%xidim) THEN
lg = Contraction(val, obj%dNTdXt)
ELSE
- CALL Reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2))
+ CALL Reallocate(lg, obj%nsd, obj%nips)
END IF
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_3
+END PROCEDURE elemsd_GetSpatialGradient_3
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_4
+MODULE PROCEDURE elemsd_GetSpatialGradient_4
INTEGER(I4B) :: ii, jj, ips
REAL(DFP), ALLOCATABLE :: r3(:, :, :)
- !!
-CALL Reallocate(lg, SIZE(val, 1), obj%refelem%nsd, &
- & SIZE(obj%N, 2))
- !!
+
+CALL Reallocate(lg, SIZE(val, 1), obj%nsd, obj%nips)
+
SELECT TYPE (obj)
TYPE IS (STElemshapeData_)
- IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN
+ IF (obj%nsd .EQ. obj%xidim) THEN
CALL SWAP(a=r3, b=val, i1=2, i2=3, i3=1)
DO ips = 1, SIZE(lg, 3)
DO jj = 1, SIZE(lg, 2)
DO ii = 1, SIZE(lg, 1)
lg(ii, jj, ips) = contraction(a1=r3(:, :, ii), &
- & a2=obj%dNTdXt(:, :, jj, ips))
+ a2=obj%dNTdXt(:, :, jj, ips))
END DO
END DO
END DO
DEALLOCATE (r3)
END IF
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_4
+END PROCEDURE elemsd_GetSpatialGradient_4
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_5
+MODULE PROCEDURE elemsd_GetSpatialGradient_5
SELECT CASE (val%varType)
CASE (constant)
- CALL reallocate(lg, obj%refelem%nsd, SIZE(obj%N, 2))
+ CALL Reallocate(lg, obj%nsd, obj%nips)
CASE (space)
- CALL getSpatialGradient(obj=obj, lg=lg, &
+ CALL GetSpatialGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace))
CASE (spacetime)
SELECT TYPE (obj)
TYPE IS (STElemShapeData_)
- CALL getSpatialGradient(obj=obj, lg=lg, &
+ CALL GetSpatialGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime))
END SELECT
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_5
+END PROCEDURE elemsd_GetSpatialGradient_5
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_6
+MODULE PROCEDURE elemsd_GetSpatialGradient_6
INTEGER(I4B) :: s(1)
SELECT CASE (val%varType)
CASE (constant)
s = SHAPE(val)
- CALL reallocate(lg, s(1), obj%refelem%nsd, &
- & SIZE(obj%N, 2))
+ CALL Reallocate(lg, s(1), obj%nsd, obj%nips)
CASE (space)
- CALL getSpatialGradient(obj=obj, lg=lg, &
+ CALL GetSpatialGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace))
CASE (spacetime)
SELECT TYPE (obj)
TYPE is (STElemShapeData_)
- CALL getSpatialGradient(obj=obj, lg=lg, &
+ CALL GetSpatialGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime))
END SELECT
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_6
+END PROCEDURE elemsd_GetSpatialGradient_6
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_7
-IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN
+MODULE PROCEDURE elemsd_GetSpatialGradient_7
+IF (obj%nsd .EQ. obj%xidim) THEN
lg = MATMUL(Val, obj%dNdXt)
ELSE
- CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), &
- & obj%refelem%nsd, SIZE(obj%N, 2))
+ CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%nsd, obj%nips)
END IF
-END PROCEDURE elemsd_getSpatialGradient_7
+END PROCEDURE elemsd_GetSpatialGradient_7
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_8
+MODULE PROCEDURE elemsd_GetSpatialGradient_8
INTEGER(I4B) :: ii, jj
!!
-CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%refelem%nsd, &
- & SIZE(obj%N, 2))
+CALL Reallocate(lg, SIZE(val, 1), SIZE(val, 2), obj%nsd, obj%nips)
SELECT TYPE (obj)
TYPE IS (STElemshapeData_)
- IF (obj%refelem%nsd .EQ. obj%refelem%xidimension) THEN
+ IF (obj%nsd .EQ. obj%xidim) THEN
DO jj = 1, SIZE(lg, 4)
DO ii = 1, SIZE(lg, 3)
lg(:, :, ii, jj) = contraction(a1=val, &
@@ -164,45 +161,44 @@
END DO
END IF
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_8
+END PROCEDURE elemsd_GetSpatialGradient_8
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_9
+MODULE PROCEDURE elemsd_GetSpatialGradient_9
INTEGER(I4B) :: s(2)
SELECT CASE (val%varType)
CASE (constant)
s = SHAPE(val)
- CALL reallocate(lg, s(1), s(2), &
- & obj%refelem%nsd, SIZE(obj%N, 2))
+ CALL Reallocate(lg, s(1), s(2), obj%nsd, obj%nips)
CASE (space)
- CALL getSpatialGradient(obj=obj, lg=lg, &
+ CALL GetSpatialGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace))
CASE (spacetime)
SELECT TYPE (obj)
TYPE is (STElemShapeData_)
- CALL getSpatialGradient(obj=obj, lg=lg, &
+ CALL GetSpatialGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime))
END SELECT
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_9
+END PROCEDURE elemsd_GetSpatialGradient_9
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_10
+MODULE PROCEDURE elemsd_GetSpatialGradient_10
REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :)
!!
SELECT CASE (val%rank)
CASE (scalar)
- CALL getSpatialGradient(obj=obj, lg=r2, val=val)
+ CALL GetSpatialGradient(obj=obj, lg=r2, val=val)
lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
DEALLOCATE (r2)
CASE (vector)
- CALL getSpatialGradient(obj=obj, lg=r3, val=val)
+ CALL GetSpatialGradient(obj=obj, lg=r3, val=val)
lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace)
DEALLOCATE (r3)
CASE (matrix)
@@ -210,13 +206,13 @@
!! TODO Extend FEVariable to support r3, which is necessary to keep
!! the gradient of rank02 tensors
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_10
+END PROCEDURE elemsd_GetSpatialGradient_10
!----------------------------------------------------------------------------
-! getSpatialGradient
+! GetSpatialGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getSpatialGradient_11
+MODULE PROCEDURE elemsd_GetSpatialGradient_11
REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :)
INTEGER(I4B) :: ii
!!
@@ -226,9 +222,9 @@
!!
CASE (scalar)
DO ii = 1, SIZE(obj)
- CALL getSpatialGradient(obj=obj(ii), lg=r2, val=val)
+ CALL GetSpatialGradient(obj=obj(ii), lg=r2, val=val)
IF (.NOT. ALLOCATED(r3)) THEN
- CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj))
+ CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj))
END IF
!!
r3(:, :, ii) = r2(:, :)
@@ -241,15 +237,15 @@
!!
CASE (vector)
DO ii = 1, SIZE(obj)
- CALL getSpatialGradient(obj=obj(ii), lg=r3, val=val)
+ CALL GetSpatialGradient(obj=obj(ii), lg=r3, val=val)
IF (.NOT. ALLOCATED(r4)) THEN
- CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj))
+ CALL Reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj))
END IF
!!
r4(:, :, :, ii) = r3(:, :, :)
END DO
- lg = QuadratureVariable(r4, typeFEVariableMatrix,&
- & typeFEVariableSpaceTime)
+ lg = QuadratureVariable(r4, typeFEVariableMatrix, &
+ typeFEVariableSpaceTime)
DEALLOCATE (r3, r4)
!!
!! matrix TODO
@@ -259,14 +255,14 @@
!! TODO Extend FEVariable to support r3, which is necessary to keep
!! the gradient of rank02 tensors
END SELECT
-END PROCEDURE elemsd_getSpatialGradient_11
+END PROCEDURE elemsd_GetSpatialGradient_11
!----------------------------------------------------------------------------
! SpatialGradient
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SpatialGradient_1
-CALL getSpatialGradient(obj=obj, lg=ans, val=val)
+CALL GetSpatialGradient(obj=obj, lg=ans, val=val)
END PROCEDURE elemsd_SpatialGradient_1
!----------------------------------------------------------------------------
@@ -274,7 +270,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SpatialGradient_2
-CALL getSpatialGradient(obj=obj, lg=ans, val=val)
+CALL GetSpatialGradient(obj=obj, lg=ans, val=val)
END PROCEDURE elemsd_SpatialGradient_2
!----------------------------------------------------------------------------
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90
index 915f5b7f5..db4beba3a 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRQIParamMethods@Methods.F90
@@ -40,7 +40,7 @@
!! Main
!!
nips = SIZE(obj%N, 2)
-nsd = obj%refelem%nsd
+nsd = obj%nsd
CALL Reallocate(h, nips)
CALL Reallocate(G, nsd, nsd, nips)
CALL Reallocate(FFT, nsd, nsd)
@@ -276,7 +276,7 @@
!!
nips = SIZE(obj(1)%N, 2)
nipt = SIZE(obj)
-nsd = obj(1)%refelem%nsd
+nsd = obj(1)%nsd
!!
CALL Reallocate(h, nips, nipt)
!!
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90
new file mode 100644
index 000000000..6c7862129
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90
@@ -0,0 +1,121 @@
+! 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(ElemShapeData_Hierarchical) Methods
+USE InputUtility, ONLY: Input
+
+USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate
+
+USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE
+
+USE HierarchicalPolynomialUtility, ONLY: HierarchicalDOF, &
+ HierarchicalEvalAll_, &
+ HierarchicalGradientEvalAll_
+
+USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, &
+ QuadraturePoint_Size => Size, &
+ GetTotalQuadraturePoints, &
+ GetQuadratureWeights_
+
+USE BaseType, ONLY: TypeQuadratureOpt, &
+ TypePolynomialOpt
+
+USE SwapUtility, ONLY: SWAP_
+
+USE Display_Method, ONLY: Display
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! ElemshapeData_InitiateHierarchical
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalElemShapeData1
+REAL(DFP), ALLOCATABLE :: temp(:, :, :)
+INTEGER(I4B) :: ipType0, basisType0, nips, nns, ii, jj, kk
+
+! CALL DEALLOCATE (obj)
+
+nips = GetTotalQuadraturePoints(obj=quad)
+
+nns = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, &
+ faceOrder=faceOrder, edgeOrder=edgeOrder)
+
+CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips)
+
+CALL GetQuadratureWeights_(obj=quad, weights=obj%ws, tsize=nips)
+
+ALLOCATE (temp(nips, nns, 3))
+
+CALL HierarchicalEvalAll_(elemType=elemType, &
+ xij=quad%points(1:xidim, 1:nips), &
+ ans=temp(:, :, 1), nrow=ii, ncol=jj, &
+ domainName=domainName, &
+ cellOrder=cellOrder, &
+ faceOrder=faceOrder, &
+ edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, &
+ faceOrient=faceOrient, &
+ edgeOrient=edgeOrient)
+
+DO CONCURRENT(ii=1:nns, jj=1:nips)
+ obj%N(ii, jj) = temp(jj, ii, 1)
+END DO
+
+CALL HierarchicalGradientEvalAll_(elemType=elemType, &
+ xij=quad%points(1:xidim, 1:nips), ans=temp, &
+ dim1=ii, dim2=jj, dim3=kk, &
+ domainName=domainName, &
+ cellOrder=cellOrder, &
+ faceOrder=faceOrder, &
+ edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, &
+ faceOrient=faceOrient, &
+ edgeOrient=edgeOrient)
+
+CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:kk), i1=2, i2=3, i3=1)
+! CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=3, i2=1, i3=2)
+
+IF (ALLOCATED(temp)) DEALLOCATE (temp)
+
+END PROCEDURE HierarchicalElemShapeData1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalElemShapeData2
+CALL HierarchicalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, &
+ xidim=refelem%xidimension, elemType=refelem%name, &
+ refelemCoord=refelem%xij, domainName=refelem%domainName, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+END PROCEDURE HierarchicalElemShapeData2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalElemShapeData3
+CALL HierarchicalElemShapeData2(obj=obj, quad=quad, refelem=refelem, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+END PROCEDURE HierarchicalElemShapeData3
+
+END SUBMODULE Methods
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90
index 3828c6c28..3304ec2d8 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_HminHmaxMethods@Methods.F90
@@ -33,7 +33,7 @@
!! Main
!!
nips = SIZE(obj%N, 2)
-nsd = obj%refelem%nsd
+nsd = obj%nsd
!!
CALL Reallocate(G, nsd, nsd)
CALL Reallocate(w, nsd)
@@ -68,7 +68,7 @@
!! Main
!!
nips = SIZE(obj%N, 2)
-nsd = obj%refelem%nsd
+nsd = obj%nsd
!!
CALL Reallocate(w, nsd)
CALL Reallocate(hmax, nips, hmin, nips)
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90
index 9b91a6d5a..2e6816a8f 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_IOMethods@Methods.F90
@@ -20,7 +20,14 @@
! summary: Methods for IO of [[elemshapedata_]] and [[stelemshapedata_]]
SUBMODULE(ElemshapeData_IOMethods) Methods
-USE BaseMethod
+USE Display_Method, ONLY: Util_Display => Display, Tostring
+
+USE MdEncode_Method, ONLY: Util_MdEncode => MdEncode
+
+USE GlobalData, ONLY: CHAR_LF2
+
+USE String_Class, ONLY: StringReallocate => Reallocate
+
IMPLICIT NONE
CONTAINS
@@ -40,139 +47,138 @@
INTEGER(I4B) :: ii
TYPE(String), ALLOCATABLE :: rh(:), ch(:)
-ans = MdEncode(obj%quad)//CHAR_LF2
-
IF (ALLOCATED(obj%N)) THEN
- CALL Reallocate(rh, SIZE(obj%N, 1))
- CALL Reallocate(ch, SIZE(obj%N, 2))
- DO ii = 1, SIZE(obj%N, 1)
+ CALL StringReallocate(rh, obj%nns)
+ CALL StringReallocate(ch, obj%nips)
+
+ DO ii = 1, obj%nns
rh(ii) = "$N_{"//tostring(ii)//"}$"
END DO
- DO ii = 1, SIZE(obj%N, 2)
+
+ DO ii = 1, obj%nips
ch(ii) = "$ips_{"//tostring(ii)//"}$"
END DO
- ans = ans//"**N**"//CHAR_LF2//MdEncode(val=obj%N, rh=rh, ch=ch)//CHAR_LF2
+
+ans = ans//"**N**"//CHAR_LF2//Util_MdEncode(val=obj%N, rh=rh, ch=ch)//CHAR_LF2
+
ELSE
ans = ans//"**N Not ALLOCATED**"//CHAR_LF2
END IF
IF (ALLOCATED(obj%dNdXi)) THEN
- CALL Reallocate(rh, SIZE(obj%dNdXi, 1))
- CALL Reallocate(ch, SIZE(obj%dNdXi, 2))
- DO ii = 1, SIZE(obj%dNdXi, 1)
+ CALL StringReallocate(rh, obj%nns)
+ CALL StringReallocate(ch, obj%xidim)
+
+ DO ii = 1, obj%nns
rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial \xi}$"
END DO
- DO ii = 1, SIZE(obj%dNdXi, 2)
+
+ DO ii = 1, obj%xidim
ch(ii) = "$\frac{\partial N}{\partial \xi_{"//tostring(ii)//"}}$"
END DO
- DO ii = 1, SIZE(obj%dNdXi, 3)
+
+ DO ii = 1, obj%nips
ans = ans//"**dNdXi(:, :, "//tostring(ii)//" )**"//CHAR_LF2// &
- & MdEncode(val=obj%dNdXi(:, :, ii), rh=rh, ch=ch)//CHAR_LF2
+ Util_MdEncode(val=obj%dNdXi(:, :, ii), rh=rh, ch=ch)//CHAR_LF2
END DO
+
ELSE
+
ans = ans//"**dNdXi Not ALLOCATED**"//CHAR_LF2
+
END IF
IF (ALLOCATED(obj%dNdXt)) THEN
- CALL Reallocate(rh, SIZE(obj%dNdXt, 1))
- CALL Reallocate(ch, SIZE(obj%dNdXt, 2))
- DO ii = 1, SIZE(obj%dNdXt, 1)
+ CALL StringReallocate(rh, obj%nns)
+ CALL StringReallocate(ch, obj%nsd)
+
+ DO ii = 1, obj%nns
rh(ii) = "$\frac{\partial N^{"//tostring(ii)//"}}{\partial x}$"
END DO
- DO ii = 1, SIZE(obj%dNdXt, 2)
+
+ DO ii = 1, obj%nsd
ch(ii) = "$\frac{\partial N}{\partial {x}_{"//tostring(ii)//"}}$"
END DO
- DO ii = 1, SIZE(obj%dNdXt, 3)
+
+ DO ii = 1, obj%nips
ans = ans//"**dNdXt(:, :, "//tostring(ii)//" )**"//CHAR_LF2// &
- & MdEncode(val=obj%dNdXt(:, :, ii), rh=rh, ch=ch)//CHAR_LF2
+ Util_MdEncode(val=obj%dNdXt(:, :, ii), rh=rh, ch=ch)//CHAR_LF2
END DO
+
ELSE
+
ans = ans//"**dNdXt Not ALLOCATED**"//CHAR_LF2
+
END IF
IF (ALLOCATED(obj%jacobian)) THEN
- CALL Reallocate(rh, SIZE(obj%jacobian, 1))
- CALL Reallocate(ch, SIZE(obj%jacobian, 2))
- DO ii = 1, SIZE(obj%jacobian, 1)
+ CALL StringReallocate(rh, obj%nsd)
+ CALL StringReallocate(ch, obj%xidim)
+
+ DO ii = 1, obj%nsd
rh(ii) = "row-"//tostring(ii)
END DO
- DO ii = 1, SIZE(obj%jacobian, 2)
+
+ DO ii = 1, obj%xidim
ch(ii) = "col-"//tostring(ii)
END DO
- DO ii = 1, SIZE(obj%jacobian, 3)
+
+ DO ii = 1, obj%nips
ans = ans//"**jacobian(:, :, "//tostring(ii)//" )**"//CHAR_LF2// &
- & MdEncode(val=obj%jacobian(:, :, ii), rh=rh, ch=ch)//CHAR_LF2
+ Util_MdEncode(val=obj%jacobian(:, :, ii), rh=rh, ch=ch)//CHAR_LF2
END DO
+
ELSE
ans = ans//"**jacobian Not ALLOCATED**"//CHAR_LF2
END IF
IF (ALLOCATED(obj%js)) THEN
- CALL Reallocate(rh, 1)
- CALL Reallocate(ch, SIZE(obj%js, 1))
+ CALL StringReallocate(rh, 1)
+ CALL StringReallocate(ch, obj%nips)
rh(1) = "js"
- DO ii = 1, SIZE(obj%js, 1)
+ DO ii = 1, obj%nips
ch(ii) = "$js_{"//tostring(ii)//"}$"
END DO
- ans = ans//"**Js**"//CHAR_LF2//MdEncode(val=obj%js, rh=rh, ch=ch)//CHAR_LF2
+
+ ans = ans//"**Js**"//CHAR_LF2//Util_MdEncode(val=obj%js, rh=rh, ch=ch)//CHAR_LF2
+
ELSE
ans = ans//"**js Not ALLOCATED**"//CHAR_LF2
END IF
IF (ALLOCATED(obj%thickness)) THEN
- CALL Reallocate(rh, 1)
- CALL Reallocate(ch, SIZE(obj%thickness, 1))
+ CALL StringReallocate(rh, 1)
+ CALL StringReallocate(ch, obj%nips)
+
rh(1) = "thickness"
- DO ii = 1, SIZE(obj%thickness, 1)
+ DO ii = 1, obj%nips
ch(ii) = "thickness${}_{"//tostring(ii)//"}$"
END DO
+
ans = ans//"**thickness**"//CHAR_LF2// &
- & MdEncode(val=obj%thickness, rh=rh, ch=ch)//CHAR_LF2
+ Util_MdEncode(val=obj%thickness, rh=rh, ch=ch)//CHAR_LF2
ELSE
ans = ans//"**thickness Not ALLOCATED**"//CHAR_LF2
END IF
IF (ALLOCATED(obj%normal)) THEN
- CALL Reallocate(rh, SIZE(obj%normal, 1))
- CALL Reallocate(ch, SIZE(obj%normal, 2))
+ CALL StringReallocate(rh, SIZE(obj%normal, 1))
+ CALL StringReallocate(ch, obj%nips)
+
DO ii = 1, SIZE(obj%normal, 1)
rh(ii) = "$n_{"//tostring(ii)//"}$"
END DO
- DO ii = 1, SIZE(obj%normal, 2)
+
+ DO ii = 1, obj%nips
ch(ii) = "$ips_{"//tostring(ii)//"}$"
END DO
+
ans = ans//"**normal**"//CHAR_LF2// &
- & MdEncode(val=obj%normal, rh=rh, ch=ch)//CHAR_LF2
+ Util_MdEncode(val=obj%normal, rh=rh, ch=ch)//CHAR_LF2
ELSE
ans = ans//"**normal not ALLOCATED**"//CHAR_LF2
END IF
-! SELECT TYPE (obj); TYPE IS (STElemShapeData_)
-! CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno)
-! CALL Display(obj%jt, "# jt: ", unitno=unitno)
-! CALL Display(obj%theta, "# theta: ", unitno=unitno)
-! CALL Display(obj%wt, "# wt: ", unitno=unitno)
-! IF (ALLOCATED(obj%T)) THEN
-! CALL Display(obj%T, "# T: ", unitno=unitno)
-! ELSE
-! CALL Display("# T: NOT ALLOCATED", unitno=unitno)
-! END IF
-! IF (ALLOCATED(obj%dTdTheta)) THEN
-! CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno)
-! ELSE
-! CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno)
-! END IF
-! IF (ALLOCATED(obj%dNTdt)) THEN
-! CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno)
-! ELSE
-! CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno)
-! END IF
-! IF (ALLOCATED(obj%dNTdXt)) THEN
-! CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno)
-! ELSE
-! CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno)
-! END IF
-! END SELECT
END PROCEDURE ElemshapeData_MdEncode
!----------------------------------------------------------------------------
@@ -180,73 +186,83 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_display_1
-CALL Display(msg, unitno=unitno)
-CALL Display("# SHAPE FUNCTION IN SPACE: ", unitno=unitno)
-CALL Display(obj%Quad, "# Quadrature Point: ", unitno=unitno)
+CALL Util_Display(msg, unitno=unitno)
+CALL Util_Display(obj%nsd, "nsd: ", unitno)
+CALL Util_Display(obj%xidim, "xidim: ", unitno)
+CALL Util_Display(obj%nns, "nns: ", unitno)
+CALL Util_Display(obj%nips, "nips: ", unitno)
+
IF (ALLOCATED(obj%N)) THEN
- CALL Display(obj%N, "# N: ", unitno)
+ CALL Util_Display(obj%N, "N: ", unitno)
ELSE
- CALL Display("# N: NOT ALLOCATED", unitno)
+ CALL Util_Display("N: NOT ALLOCATED", unitno)
END IF
IF (ALLOCATED(obj%dNdXi)) THEN
- CALL Display(obj%dNdXi, "# dNdXi: ", unitno)
+ CALL Util_Display(obj%dNdXi, "dNdXi: ", unitno)
ELSE
- CALL Display("# dNdXi: NOT ALLOCATED", unitno)
+ CALL Util_Display("dNdXi: NOT ALLOCATED", unitno)
END IF
IF (ALLOCATED(obj%dNdXt)) THEN
- CALL Display(obj%dNdXt, "# dNdXt: ", unitno)
+ CALL Util_Display(obj%dNdXt, "dNdXt: ", unitno)
ELSE
- CALL Display("# dNdXt: NOT ALLOCATED", unitno)
+ CALL Util_Display("dNdXt: NOT ALLOCATED", unitno)
END IF
IF (ALLOCATED(obj%jacobian)) THEN
- CALL Display(obj%Jacobian, "# jacobian: ", unitno)
+ CALL Util_Display(obj%Jacobian, "jacobian: ", unitno)
ELSE
- CALL Display("# jacobian: NOT ALLOCATED", unitno)
+ CALL Util_Display("jacobian: NOT ALLOCATED", unitno)
END IF
+
IF (ALLOCATED(obj%js)) THEN
- CALL Display(obj%js, "# js: ", unitno)
+ CALL Util_Display(obj%js, "js: ", unitno)
ELSE
- CALL Display("# js: NOT ALLOCATED", unitno)
+ CALL Util_Display("js: NOT ALLOCATED", unitno)
END IF
+
+IF (ALLOCATED(obj%ws)) THEN
+ CALL Util_Display(obj%ws, "ws: ", unitno)
+ELSE
+ CALL Util_Display("ws: NOT ALLOCATED", unitno)
+END IF
+
IF (ALLOCATED(obj%thickness)) THEN
- CALL Display(obj%thickness, "# thickness: ", unitno)
+ CALL Util_Display(obj%thickness, "thickness: ", unitno)
ELSE
- CALL Display("# thickness: NOT ALLOCATED", unitno)
+ CALL Util_Display("thickness: NOT ALLOCATED", unitno)
END IF
IF (ALLOCATED(obj%coord)) THEN
- CALL Display(obj%coord, "# coord: ", unitno)
+ CALL Util_Display(obj%coord, "coord: ", unitno)
ELSE
- CALL Display("# coord: NOT ALLOCATED", unitno)
+ CALL Util_Display("coord: NOT ALLOCATED", unitno)
END IF
IF (ALLOCATED(obj%normal)) THEN
- CALL Display(obj%normal, "# normal: ", unitno)
+ CALL Util_Display(obj%normal, "normal: ", unitno)
ELSE
- CALL Display("# normal: NOT ALLOCATED", unitno)
+ CALL Util_Display("normal: NOT ALLOCATED", unitno)
END IF
SELECT TYPE (obj); TYPE IS (STElemShapeData_)
- CALL Display("# SHAPE FUNCTION IN TIME: ", unitno=unitno)
- CALL Display(obj%jt, "# jt: ", unitno=unitno)
- CALL Display(obj%theta, "# theta: ", unitno=unitno)
- CALL Display(obj%wt, "# wt: ", unitno=unitno)
+ CALL Util_Display("SHAPE FUNCTION IN TIME: ", unitno=unitno)
+ CALL Util_Display(obj%jt, "jt: ", unitno=unitno)
+ CALL Util_Display(obj%wt, "wt: ", unitno=unitno)
IF (ALLOCATED(obj%T)) THEN
- CALL Display(obj%T, "# T: ", unitno=unitno)
+ CALL Util_Display(obj%T, "T: ", unitno=unitno)
ELSE
- CALL Display("# T: NOT ALLOCATED", unitno=unitno)
+ CALL Util_Display("T: NOT ALLOCATED", unitno=unitno)
END IF
IF (ALLOCATED(obj%dTdTheta)) THEN
- CALL Display(obj%dTdTheta, "# dTdTheta: ", unitno=unitno)
+ CALL Util_Display(obj%dTdTheta, "dTdTheta: ", unitno=unitno)
ELSE
- CALL Display("# dTdTheta: NOT ALLOCATED", unitno=unitno)
+ CALL Util_Display("dTdTheta: NOT ALLOCATED", unitno=unitno)
END IF
IF (ALLOCATED(obj%dNTdt)) THEN
- CALL Display(obj%dNTdt, "# dNTdt: ", unitno=unitno)
+ CALL Util_Display(obj%dNTdt, "dNTdt: ", unitno=unitno)
ELSE
- CALL Display("# dNTdt: NOT ALLOCATED", unitno=unitno)
+ CALL Util_Display("dNTdt: NOT ALLOCATED", unitno=unitno)
END IF
IF (ALLOCATED(obj%dNTdXt)) THEN
- CALL Display(obj%dNTdXt, "# dNTdXt: ", unitno=unitno)
+ CALL Util_Display(obj%dNTdXt, "dNTdXt: ", unitno=unitno)
ELSE
- CALL Display("# dNTdXt: NOT ALLOCATED", unitno=unitno)
+ CALL Util_Display("dNTdXt: NOT ALLOCATED", unitno=unitno)
END IF
END SELECT
END PROCEDURE elemsd_display_1
@@ -259,7 +275,7 @@
INTEGER(I4B) :: ii
DO ii = 1, SIZE(obj)
CALL Display(obj=obj(ii), msg=TRIM(msg)//"("//tostring(ii)//"): ", &
- & unitno=unitno)
+ unitno=unitno)
END DO
END PROCEDURE elemsd_display_2
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90
index 3b6cc592c..321a86582 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90
@@ -28,6 +28,15 @@
interpol = MATMUL(val, obj%N)
END PROCEDURE scalar_getinterpolation_1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE scalar_getinterpolation1_
+tsize = SIZE(obj%N, 2)
+interpol(1:tsize) = MATMUL(val, obj%N)
+END PROCEDURE scalar_getinterpolation1_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -39,6 +48,18 @@
END SELECT
END PROCEDURE scalar_getinterpolation_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE scalar_getinterpolation2_
+SELECT TYPE (obj)
+TYPE IS (STElemShapeData_)
+ tsize = SIZE(obj%N, 2)
+ interpol = MATMUL(MATMUL(val, obj%T), obj%N)
+END SELECT
+END PROCEDURE scalar_getinterpolation2_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -51,6 +72,19 @@
END DO
END PROCEDURE scalar_getinterpolation_3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE scalar_getinterpolation3_
+INTEGER(I4B) :: ipt
+nrow = SIZE(obj(1)%N, 2)
+ncol = SIZE(obj)
+DO ipt = 1, ncol
+ interpol(1:nrow, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N)
+END DO
+END PROCEDURE scalar_getinterpolation3_
+
!----------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
@@ -78,6 +112,39 @@
END SELECT
END PROCEDURE scalar_getinterpolation_4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE scalar_getinterpolation4_
+SELECT CASE (val%vartype)
+CASE (Constant)
+ tsize = SIZE(obj%N, 2)
+ interpol(1:tsize) = Get(val, TypeFEVariableScalar, TypeFEVariableConstant)
+CASE (Space)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ CALL GetInterpolation_(obj=obj, interpol=interpol, &
+ val=Get(val, TypeFEVariableScalar, &
+ TypeFEVariableSpace), &
+ tsize=tsize)
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpace, &
+ val=interpol, tsize=tsize)
+ END IF
+CASE (SpaceTime)
+ SELECT TYPE (obj)
+ TYPE IS (STElemShapeData_)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ CALL GetInterpolation_(obj=obj, interpol=interpol, &
+ val=Get(val, TypeFEVariableScalar, &
+ TypeFEVariableSpaceTime), &
+ tsize=tsize)
+ END IF
+ END SELECT
+END SELECT
+END PROCEDURE scalar_getinterpolation4_
+
!----------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
@@ -148,6 +215,52 @@
!!
END PROCEDURE scalar_getinterpolation_5
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE scalar_getinterpolation5_
+INTEGER(I4B) :: ii
+nrow = SIZE(obj(1)%N, 2)
+ncol = SIZE(obj)
+SELECT CASE (val%vartype)
+CASE (Constant)
+ interpol(1:nrow, 1:ncol) = Get(val, TypeFEVariableScalar, TypeFEVariableConstant)
+CASE (Space)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ DO ii = 1, ncol
+ CALL GetInterpolation_(obj=obj(ii), &
+ interpol=interpol(1:nrow, ii), &
+ val=Get(val, TypeFEVariableScalar, &
+ TypeFEVariableSpace), &
+ tsize=nrow)
+ END DO
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpace, &
+ val=interpol(1:nrow, 1), tsize=nrow)
+ DO ii = 2, ncol
+ interpol(1:nrow, ii) = interpol(1:nrow, 1)
+ END DO
+ END IF
+CASE (SpaceTime)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ DO ii = 1, ncol
+ CALL GetInterpolation_(obj=obj(ii), &
+ interpol=interpol(1:nrow, ii), &
+ val=Get(val, TypeFEVariableScalar, &
+ TypeFEVariableSpaceTime), &
+ tsize=nrow)
+ END DO
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=typeFEVariableSpaceTime, &
+ val=interpol, nrow=nrow, ncol=ncol)
+ END IF
+END SELECT
+
+END PROCEDURE scalar_getinterpolation5_
+
!---------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
@@ -156,6 +269,16 @@
interpol = MATMUL(val, obj%N)
END PROCEDURE vector_getinterpolation_1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE vector_getinterpolation1_
+nrow = SIZE(val, 1)
+ncol = SIZE(obj%N, 2)
+interpol(1:nrow, 1:ncol) = MATMUL(val, obj%N)
+END PROCEDURE vector_getinterpolation1_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -167,6 +290,19 @@
END SELECT
END PROCEDURE vector_getinterpolation_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE vector_getinterpolation2_
+SELECT TYPE (obj)
+TYPE IS (STElemShapeData_)
+ nrow = SIZE(val, 1)
+ ncol = SIZE(obj%N, 2)
+ interpol(1:nrow, 1:ncol) = MATMUL(MATMUL(val, obj%T), obj%N)
+END SELECT
+END PROCEDURE vector_getinterpolation2_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -180,6 +316,22 @@
END DO
END PROCEDURE vector_getinterpolation_3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE vector_getinterpolation3_
+INTEGER(I4B) :: ipt
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(obj(1)%N, 2)
+dim3 = SIZE(obj)
+DO ipt = 1, dim3
+ interpol(1:dim1, 1:dim2, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), &
+ obj(ipt)%N)
+END DO
+END PROCEDURE vector_getinterpolation3_
+
!----------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
@@ -227,6 +379,47 @@
!!
END PROCEDURE vector_getinterpolation_4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE vector_getinterpolation4_
+INTEGER(I4B) :: ii
+
+SELECT CASE (val%vartype)
+CASE (Constant)
+ CALL Get_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableConstant, &
+ val=interpol(:, 1), tsize=nrow)
+ ncol = SIZE(obj%N, 2)
+ DO ii = 2, ncol
+ interpol(1:nrow, ii) = interpol(1:nrow, 1)
+ END DO
+CASE (Space)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ CALL GetInterpolation_(obj=obj, &
+ val=Get(val, TypeFEVariableVector, &
+ TypeFEVariableSpace), &
+ interpol=interpol, &
+ nrow=nrow, ncol=ncol)
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpace, &
+ val=interpol, nrow=nrow, ncol=ncol)
+ END IF
+CASE (SpaceTime)
+ SELECT TYPE (obj)
+ TYPE IS (STElemShapeData_)
+ CALL GetInterpolation_(obj=obj, &
+ val=Get(val, TypeFEVariableVector, &
+ TypeFEVariableSpaceTime), &
+ interpol=interpol, &
+ nrow=nrow, ncol=ncol)
+ END SELECT
+END SELECT
+
+END PROCEDURE vector_getinterpolation4_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -311,6 +504,62 @@
!!
END PROCEDURE vector_getinterpolation_5
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE vector_getinterpolation5_
+INTEGER(I4B) :: ii, jj
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(obj(1)%N, 2)
+dim3 = SIZE(obj)
+SELECT CASE (val%vartype)
+CASE (Constant)
+ CALL Get_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableConstant, &
+ val=interpol(:, 1, 1), tsize=dim1)
+ DO jj = 1, dim3
+ DO ii = 1, dim2
+ IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE
+ interpol(1:dim1, ii, jj) = interpol(1:dim1, 1, 1)
+ END DO
+ END DO
+CASE (Space)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ DO ii = 1, dim3
+ CALL GetInterpolation_(obj=obj(ii), &
+ val=Get(val, TypeFEVariableVector, &
+ TypeFEVariableSpace), &
+ interpol=interpol(1:dim1, 1:dim2, ii), &
+ nrow=dim1, ncol=dim2)
+ END DO
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpace, &
+ val=interpol(:, :, 1), nrow=dim1, ncol=dim2)
+ DO ii = 2, SIZE(obj)
+ interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1)
+ END DO
+ END IF
+CASE (SpaceTime)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ DO ii = 1, SIZE(obj)
+ CALL GetInterpolation_(obj=obj(ii), &
+ val=Get(val, TypeFEVariableVector, &
+ TypeFEVariableSpaceTime), &
+ interpol=interpol(1:dim1, 1:dim2, ii), &
+ nrow=dim1, ncol=dim2)
+ END DO
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpaceTime, &
+ val=interpol, dim1=dim1, dim2=dim2, dim3=dim3)
+ END IF
+END SELECT
+
+END PROCEDURE vector_getinterpolation5_
+
!----------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
@@ -319,6 +568,17 @@
interpol = MATMUL(val, obj%N)
END PROCEDURE matrix_getinterpolation_1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matrix_getinterpolation1_
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = SIZE(obj%N, 2)
+interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(val, obj%N)
+END PROCEDURE matrix_getinterpolation1_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -330,6 +590,20 @@
END SELECT
END PROCEDURE matrix_getinterpolation_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matrix_getinterpolation2_
+SELECT TYPE (obj)
+TYPE IS (STElemShapeData_)
+ dim1 = SIZE(val, 1)
+ dim2 = SIZE(val, 2)
+ dim3 = SIZE(obj%N, 2)
+ interpol(1:dim1, 1:dim2, 1:dim3) = MATMUL(MATMUL(val, obj%T), obj%N)
+END SELECT
+END PROCEDURE matrix_getinterpolation2_
+
!----------------------------------------------------------------------------
! getSTinterpolation
!----------------------------------------------------------------------------
@@ -373,6 +647,48 @@
END SELECT
END PROCEDURE matrix_getinterpolation_4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matrix_getinterpolation4_
+INTEGER(I4B) :: ii
+
+SELECT CASE (val%vartype)
+CASE (Constant)
+ dim3 = SIZE(obj%N, 2)
+ CALL Get_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableConstant, &
+ val=interpol(:, :, 1), nrow=dim1, ncol=dim2)
+ DO ii = 2, dim3
+ interpol(1:dim1, 1:dim2, ii) = interpol(1:dim1, 1:dim2, 1)
+ END DO
+CASE (Space)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ CALL GetInterpolation_(obj=obj, &
+ val=Get(val, TypeFEVariableMatrix, &
+ TypeFEVariableSpace), &
+ interpol=interpol, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpace, val=interpol, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+ END IF
+CASE (SpaceTime)
+ SELECT TYPE (obj)
+ TYPE IS (STElemShapeData_)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ CALL GetInterpolation_(obj=obj, &
+ val=Get(val, TypeFEVariableMatrix, &
+ TypeFEVariableSpaceTime), &
+ interpol=interpol, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+ END IF
+ END SELECT
+END SELECT
+END PROCEDURE matrix_getinterpolation4_
+
!----------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
@@ -461,6 +777,63 @@
!!
END PROCEDURE matrix_getinterpolation_5
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matrix_getinterpolation5_
+INTEGER(I4B) :: ii, jj
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = SIZE(obj(1)%N, 2)
+dim4 = SIZE(obj)
+
+SELECT CASE (val%vartype)
+CASE (Constant)
+ CALL Get_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableConstant, val=interpol(:, :, 1, 1), &
+ nrow=dim1, ncol=dim2)
+ DO jj = 1, dim3
+ DO ii = 1, dim4
+ IF (jj .EQ. 1 .AND. ii .EQ. 1) CYCLE
+ interpol(1:dim1, 1:dim2, ii, jj) = interpol(1:dim1, 1:dim2, 1, 1)
+ END DO
+ END DO
+CASE (Space)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ DO ii = 1, dim4
+ CALL GetInterpolation_(obj=obj(ii), &
+ val=Get(val, TypeFEVariableMatrix, &
+ TypeFEVariableSpace), &
+ interpol=interpol(:, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+ END DO
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpace, val=interpol(:, :, :, 1), &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+ DO ii = 2, dim4
+ interpol(1:dim1, 1:dim2, 1:dim3, ii) = &
+ interpol(1:dim1, 1:dim2, 1:dim3, 1)
+ END DO
+ END IF
+CASE (SpaceTime)
+ IF (val%DefineOn .EQ. Nodal) THEN
+ DO ii = 1, dim4
+ CALL GetInterpolation_(obj=obj(ii), &
+ val=Get(val, TypeFEVariableMatrix, &
+ TypeFEVariableSpaceTime), &
+ interpol=interpol(:, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+ END DO
+ ELSE
+ CALL Get_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpaceTime, val=interpol, &
+ dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+ END IF
+END SELECT
+END PROCEDURE matrix_getinterpolation5_
+
!----------------------------------------------------------------------------
! getinterpolation
!----------------------------------------------------------------------------
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90
new file mode 100644
index 000000000..ad274c688
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90
@@ -0,0 +1,169 @@
+! 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(ElemShapeData_Lagrange) Methods
+USE InputUtility, ONLY: Input
+
+USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate
+
+USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE
+
+USE LagrangePolynomialUtility, ONLY: LagrangeDOF, &
+ InterpolationPoint_, &
+ LagrangeEvalAll, &
+ LagrangeEvalAll_, &
+ LagrangeGradientEvalAll_
+
+USE QuadraturePoint_Method, ONLY: GetQuadraturePoints, &
+ QuadraturePoint_Size => Size, &
+ GetTotalQuadraturePoints, &
+ GetQuadratureWeights_
+
+USE BaseType, ONLY: TypeQuadratureOpt, &
+ TypePolynomialOpt
+
+USE SwapUtility, ONLY: SWAP_
+
+USE Display_Method, ONLY: Display
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! ElemshapeData_InitiateLagrange
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeElemShapeData1
+REAL(DFP), ALLOCATABLE :: xij(:, :), coeff0(:, :), temp(:, :, :)
+INTEGER(I4B) :: ipType0, basisType0, nips, nns, indx(10), ii, jj
+
+ipType0 = Input(default=TypeQuadratureOpt%equidistance, option=ipType)
+basisType0 = Input(default=TypePolynomialOpt%Monomial, option=basisType)
+
+! CALL DEALLOCATE (obj)
+
+nips = GetTotalQuadraturePoints(obj=quad)
+! pt = quad%points(1:quad%txi, 1:nips)
+! wt = quad%points(quad%txi + 1, 1:nips)
+
+nns = LagrangeDOF(order=order, elemType=elemType)
+
+#ifdef DEBUG_VER
+IF (nns .EQ. 0) THEN
+ CALL Display("Error: LagrangeDOF returned zero DOF")
+ STOP
+END IF
+#endif
+
+CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips)
+
+CALL GetQuadratureWeights_(obj=quad, weights=obj%ws, tsize=nips)
+
+ALLOCATE (xij(3, nns), temp(nips, nns, 3))
+
+CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType0, &
+ layout="VEFC", xij=refelemCoord(1:xidim, :), alpha=alpha, beta=beta, &
+ lambda=lambda, ans=xij, nrow=indx(1), ncol=indx(2))
+
+IF (PRESENT(coeff)) THEN
+
+ CALL LagrangeEvalAll_(order=order, &
+ elemType=elemType, &
+ x=quad%points(1:quad%txi, 1:nips), &
+ xij=xij(1:xidim, :), &
+ domainName=domainName, &
+ basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ coeff=coeff(1:nns, 1:nns), firstCall=firstCall, &
+ ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2))
+
+ DO CONCURRENT(ii=1:nns, jj=1:nips)
+ obj%N(ii, jj) = temp(jj, ii, 1)
+ END DO
+
+ CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, &
+ x=quad%points(1:quad%txi, 1:nips), &
+ xij=xij(1:xidim, :), &
+ domainName=domainName, &
+ basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ coeff=coeff(1:nns, 1:nns), &
+ firstCall=.FALSE., &
+ ans=temp, &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3))
+
+ELSE
+
+ ALLOCATE (coeff0(nns, nns))
+
+ ! obj%N = TRANSPOSE(LagrangeEvalAll(order=order, elemType=elemType, &
+ CALL LagrangeEvalAll_(order=order, elemType=elemType, &
+ x=quad%points(1:quad%txi, 1:nips), &
+ xij=xij(1:xidim, :), &
+ domainName=domainName, &
+ basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ coeff=coeff0, firstCall=.TRUE., &
+ ans=temp(:, :, 1), nrow=indx(1), ncol=indx(2))
+
+ obj%N(1:nns, 1:nips) = TRANSPOSE(temp(1:nips, 1:nns, 1))
+
+ ! dNdXi = LagrangeGradientEvalAll(order=order, elemType=elemType, &
+ CALL LagrangeGradientEvalAll_(order=order, elemType=elemType, &
+ x=quad%points(1:quad%txi, 1:nips), &
+ xij=xij(1:xidim, :), &
+ domainName=domainName, &
+ basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ coeff=coeff0, firstCall=.FALSE., &
+ ans=temp, &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3))
+END IF
+
+CALL SWAP_(a=obj%dNdXi, b=temp(1:indx(1), 1:indx(2), 1:indx(3)), i1=2, &
+ i2=3, i3=1)
+
+IF (ALLOCATED(temp)) DEALLOCATE (temp)
+IF (ALLOCATED(xij)) DEALLOCATE (xij)
+IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0)
+
+END PROCEDURE LagrangeElemShapeData1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeElemShapeData2
+CALL LagrangeElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, &
+ xidim=refelem%xidimension, elemType=refelem%name, &
+ refelemCoord=refelem%xij, domainName=refelem%domainName, order=order, &
+ ipType=ipType, basisType=basisType, coeff=coeff, firstCall=firstCall, &
+ alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE LagrangeElemShapeData2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeElemShapeData3
+CALL LagrangeElemShapeData2(obj=obj, quad=quad, refelem=refelem, &
+ order=order, ipType=ipType, basisType=basisType, coeff=coeff, &
+ firstCall=firstCall, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE LagrangeElemShapeData3
+
+END SUBMODULE Methods
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90
index 82ee7c65f..d998a2392 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_LocalGradientMethods@Methods.F90
@@ -21,148 +21,147 @@
CONTAINS
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_1
+MODULE PROCEDURE elemsd_GetLocalGradient_1
lg = MATMUL(Val, obj%dNdXi)
!! matmul r1 r3
-END PROCEDURE elemsd_getLocalGradient_1
+END PROCEDURE elemsd_GetLocalGradient_1
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_2
+MODULE PROCEDURE elemsd_GetLocalGradient_2
lg = MATMUL(Val, obj%dNdXi)
!! matmul r2 r3
-END PROCEDURE elemsd_getLocalGradient_2
+END PROCEDURE elemsd_GetLocalGradient_2
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_3
+MODULE PROCEDURE elemsd_GetLocalGradient_3
SELECT TYPE (obj)
TYPE IS (STElemshapeData_)
lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi)
!! matmul r1 r3
END SELECT
-END PROCEDURE elemsd_getLocalGradient_3
+END PROCEDURE elemsd_GetLocalGradient_3
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_4
+MODULE PROCEDURE elemsd_GetLocalGradient_4
SELECT TYPE (obj)
TYPE IS (STElemshapeData_)
lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi)
!! (r3.r1).r3 => r2.r3
END SELECT
-END PROCEDURE elemsd_getLocalGradient_4
+END PROCEDURE elemsd_GetLocalGradient_4
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_5
+MODULE PROCEDURE elemsd_GetLocalGradient_5
SELECT CASE (val%varType)
CASE (constant)
- CALL reallocate(lg, obj%refelem%xidimension, SIZE(obj%N, 2))
+ CALL Reallocate(lg, obj%xidim, obj%nips)
CASE (space)
- CALL getLocalGradient(obj=obj, lg=lg, &
+ CALL GetLocalGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpace))
CASE (spacetime)
SELECT TYPE (obj)
TYPE is (STElemShapeData_)
- CALL getLocalGradient(obj=obj, lg=lg, &
+ CALL GetLocalGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime))
END SELECT
END SELECT
-END PROCEDURE elemsd_getLocalGradient_5
+END PROCEDURE elemsd_GetLocalGradient_5
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_6
+MODULE PROCEDURE elemsd_GetLocalGradient_6
INTEGER(I4B) :: s(1)
!!
SELECT CASE (val%varType)
CASE (constant)
s = SHAPE(val)
- CALL reallocate(lg, s(1), obj%refelem%xidimension, SIZE(obj%N, 2))
+ CALL Reallocate(lg, s(1), obj%xidim, obj%nips)
CASE (space)
- CALL getLocalGradient(obj=obj, lg=lg, &
+ CALL GetLocalGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableVector, TypeFEVariableSpace))
CASE (spacetime)
SELECT TYPE (obj)
TYPE is (STElemShapeData_)
- CALL getLocalGradient(obj=obj, lg=lg, &
+ CALL GetLocalGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime))
END SELECT
END SELECT
-END PROCEDURE elemsd_getLocalGradient_6
+END PROCEDURE elemsd_GetLocalGradient_6
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_7
+MODULE PROCEDURE elemsd_GetLocalGradient_7
lg = MATMUL(val, obj%dNdXi)
!! r3.r4
-END PROCEDURE elemsd_getLocalGradient_7
+END PROCEDURE elemsd_GetLocalGradient_7
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_8
+MODULE PROCEDURE elemsd_GetLocalGradient_8
SELECT TYPE (obj)
TYPE IS (STElemShapeData_)
lg = MATMUL(MATMUL(Val, obj%T), obj%dNdXi)
!! (r4.r1).r3
END SELECT
-END PROCEDURE elemsd_getLocalGradient_8
+END PROCEDURE elemsd_GetLocalGradient_8
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_9
+MODULE PROCEDURE elemsd_GetLocalGradient_9
INTEGER(I4B) :: s(2)
SELECT CASE (val%varType)
CASE (constant)
s = SHAPE(val)
- CALL reallocate(lg, s(1), s(2), &
- & obj%refelem%xidimension, SIZE(obj%N, 2))
+ CALL Reallocate(lg, s(1), s(2), obj%xidim, obj%nips)
CASE (space)
- CALL getLocalGradient(obj=obj, lg=lg, &
+ CALL GetLocalGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpace))
CASE (spacetime)
SELECT TYPE (obj)
TYPE is (STElemShapeData_)
- CALL getLocalGradient(obj=obj, lg=lg, &
+ CALL GetLocalGradient(obj=obj, lg=lg, &
& Val=Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime))
END SELECT
END SELECT
-END PROCEDURE elemsd_getLocalGradient_9
+END PROCEDURE elemsd_GetLocalGradient_9
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_10
+MODULE PROCEDURE elemsd_GetLocalGradient_10
REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :)
!!
SELECT CASE (val%rank)
CASE (scalar)
- CALL getLocalGradient(obj=obj, lg=r2, val=val)
+ CALL GetLocalGradient(obj=obj, lg=r2, val=val)
lg = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
DEALLOCATE (r2)
CASE (vector)
- CALL getLocalGradient(obj=obj, lg=r3, val=val)
+ CALL GetLocalGradient(obj=obj, lg=r3, val=val)
lg = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace)
DEALLOCATE (r3)
CASE (matrix)
@@ -170,13 +169,13 @@
!! TODO Extend FEVariable to support r3, which is necessary to keep
!! the gradient of rank02 tensors
END SELECT
-END PROCEDURE elemsd_getLocalGradient_10
+END PROCEDURE elemsd_GetLocalGradient_10
!----------------------------------------------------------------------------
-! getLocalGradient
+! GetLocalGradient
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_getLocalGradient_11
+MODULE PROCEDURE elemsd_GetLocalGradient_11
REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :)
INTEGER(I4B) :: ii
!!
@@ -186,9 +185,9 @@
!!
CASE (scalar)
DO ii = 1, SIZE(obj)
- CALL getLocalGradient(obj=obj(ii), lg=r2, val=val)
+ CALL GetLocalGradient(obj=obj(ii), lg=r2, val=val)
IF (.NOT. ALLOCATED(r3)) THEN
- CALL reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj))
+ CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), SIZE(obj))
END IF
!!
r3(:, :, ii) = r2(:, :)
@@ -201,9 +200,9 @@
!!
CASE (vector)
DO ii = 1, SIZE(obj)
- CALL getLocalGradient(obj=obj(ii), lg=r3, val=val)
+ CALL GetLocalGradient(obj=obj(ii), lg=r3, val=val)
IF (.NOT. ALLOCATED(r4)) THEN
- CALL reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj))
+ CALL Reallocate(r4, SIZE(r3, 1), SIZE(r3, 2), SIZE(r3, 3), SIZE(obj))
END IF
!!
r4(:, :, :, ii) = r3(:, :, :)
@@ -219,14 +218,14 @@
!! TODO Extend FEVariable to support r3, which is necessary to keep
!! the gradient of rank02 tensors
END SELECT
-END PROCEDURE elemsd_getLocalGradient_11
+END PROCEDURE elemsd_GetLocalGradient_11
!----------------------------------------------------------------------------
! LocalGradient
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_LocalGradient_1
-CALL getLocalGradient(obj=obj, lg=ans, val=val)
+CALL GetLocalGradient(obj=obj, lg=ans, val=val)
END PROCEDURE elemsd_LocalGradient_1
!----------------------------------------------------------------------------
@@ -234,7 +233,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_LocalGradient_2
-CALL getLocalGradient(obj=obj, lg=ans, val=val)
+CALL GetLocalGradient(obj=obj, lg=ans, val=val)
END PROCEDURE elemsd_LocalGradient_2
!----------------------------------------------------------------------------
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90
new file mode 100644
index 000000000..c2e542cbe
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_Orthogonal@Methods.F90
@@ -0,0 +1,99 @@
+! 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(ElemShapeData_Orthogonal) Methods
+USE LagrangePolynomialUtility, ONLY: LagrangeDOF
+
+USE ElemShapeData_Method, ONLY: Elemsd_Allocate => ALLOCATE
+
+USE OrthogonalPolynomialUtility, ONLY: OrthogonalEvalAll_, &
+ OrthogonalGradientEvalAll_
+
+USE SwapUtility, ONLY: SWAP_
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! ElemshapeData_InitiateOrthogonal
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalElemShapeData1
+REAL(DFP), ALLOCATABLE :: temp(:, :, :)
+INTEGER(I4B) :: nips, nns, ii, jj, kk
+
+! CALL DEALLOCATE (obj)
+
+nips = SIZE(quad%points, 2)
+! INFO:
+! pt = quad%points(1:quad%txi, 1:nips)
+! wt = quad%points(quad%txi + 1, 1:nips)
+
+nns = LagrangeDOF(elemType=elemType, order=order)
+
+CALL Elemsd_Allocate(obj=obj, nsd=nsd, xidim=xidim, nns=nns, nips=nips)
+
+DO CONCURRENT(jj=1:nips)
+ obj%ws(jj) = quad%points(1 + xidim, jj)
+END DO
+
+ALLOCATE (temp(nips, nns, 3))
+
+CALL OrthogonalEvalAll_(elemType=elemType, xij=quad%points(1:xidim, 1:nips), &
+ ans=temp(:, :, 1), nrow=ii, ncol=jj, domainName=domainName, order=order, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
+
+DO CONCURRENT(ii=1:nns, jj=1:nips)
+ obj%N(ii, jj) = temp(jj, ii, 1)
+END DO
+
+CALL OrthogonalGradientEvalAll_(elemType=elemType, &
+ xij=quad%points(1:xidim, 1:nips), ans=temp, &
+ dim1=ii, dim2=jj, dim3=kk, &
+ domainName=domainName, order=order, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
+
+CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:kk), i1=2, i2=3, i3=1)
+! CALL SWAP_(a=obj%dNdXi, b=temp(1:ii, 1:jj, 1:jj), i1=3, i2=1, i3=2)
+
+DEALLOCATE (temp)
+
+END PROCEDURE OrthogonalElemShapeData1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalElemShapeData2
+CALL OrthogonalElemShapeData1(obj=obj, quad=quad, nsd=refelem%nsd, &
+ xidim=refelem%xidimension, elemType=refelem%name, refelemCoord=refelem%xij, &
+ domainName=refelem%domainName, order=order, basisType=basisType, &
+ alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE OrthogonalElemShapeData2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalElemShapeData3
+CALL OrthogonalElemShapeData2(obj=obj, quad=quad, refelem=refelem, &
+ order=order, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE OrthogonalElemShapeData3
+
+END SUBMODULE Methods
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90
index 2998cf756..c4819ecda 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90
@@ -38,6 +38,23 @@
!!
END PROCEDURE getProjectionOfdNdXt_1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE getProjectionOfdNdXt1_
+INTEGER(I4B) :: ii, nsd
+
+nrow = SIZE(obj%dNdXt, 1)
+ncol = SIZE(obj%dNdXt, 3)
+nsd = SIZE(obj%dNdXt, 2)
+
+DO ii = 1, ncol
+ cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), Val(1:nsd))
+END DO
+
+END PROCEDURE getProjectionOfdNdXt1_
+
!----------------------------------------------------------------------------
! getProjectionOfdNdXt
!----------------------------------------------------------------------------
@@ -59,6 +76,24 @@
!!
END PROCEDURE getProjectionOfdNdXt_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE getProjectionOfdNdXt2_
+INTEGER(I4B) :: ii, nsd
+REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3))
+
+CALL GetInterpolation_(obj=obj, val=val, interpol=cbar, nrow=nrow, ncol=ncol)
+nsd = nrow
+nrow = SIZE(obj%dNdXt, 1)
+
+DO ii = 1, ncol
+ cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), cbar(1:nsd, ii))
+END DO
+
+END PROCEDURE getProjectionOfdNdXt2_
+
!----------------------------------------------------------------------------
! getProjectionOfdNdXt
!----------------------------------------------------------------------------
@@ -77,6 +112,23 @@
!!
END PROCEDURE getProjectionOfdNdXt_3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE getProjectionOfdNdXt3_
+INTEGER(I4B) :: ii, nsd
+
+nrow = SIZE(obj%dNdXt, 1)
+ncol = SIZE(obj%dNdXt, 3)
+nsd = SIZE(obj%dNdXt, 2)
+
+DO ii = 1, ncol
+ cdNdXt(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), val(1:nsd, ii))
+END DO
+
+END PROCEDURE getProjectionOfdNdXt3_
+
!----------------------------------------------------------------------------
! getProjectionOfdNTdXt
!----------------------------------------------------------------------------
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90
index 2353d3d0f..8b773d8d3 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90
@@ -16,7 +16,14 @@
!
SUBMODULE(ElemshapeData_SetMethods) Methods
-USE BaseMethod
+USE ProductUtility, ONLY: VectorProduct, OuterProd
+
+USE InvUtility, ONLY: Det, Inv
+
+USE ReallocateUtility, ONLY: Reallocate
+
+USE MatmulUtility
+
IMPLICIT NONE
CONTAINS
@@ -26,7 +33,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SetThickness
-obj%Thickness = MATMUL(val, N)
+obj%thickness(1:obj%nips) = MATMUL(val, N)
END PROCEDURE elemsd_SetThickness
!----------------------------------------------------------------------------
@@ -42,7 +49,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SetBarycentricCoord
-obj%Coord = MATMUL(val, N)
+obj%coord(1:obj%nsd, 1:obj%nips) = MATMUL(val, N)
END PROCEDURE elemsd_SetBarycentricCoord
!----------------------------------------------------------------------------
@@ -59,27 +66,40 @@
MODULE PROCEDURE elemsd_SetJs
! Define internal variable
-INTEGER(I4B) :: xidim, nsd, nips, ips
+INTEGER(I4B) :: ips, caseid
+
REAL(DFP) :: aa, bb, ab
-!
-xidim = obj%RefElem%XiDimension
-nsd = obj%RefElem%nsd
-nips = SIZE(obj%N, 2)
-!
-DO ips = 1, nips
- IF (nsd .EQ. xidim) THEN
- obj%Js(ips) = det(obj%Jacobian(:, :, ips))
- ELSE IF (xidim .EQ. 1 .AND. xidim .NE. nsd) THEN
- obj%Js(ips) = &
- & SQRT(DOT_PRODUCT(obj%Jacobian(:, 1, ips), &
- & obj%Jacobian(:, 1, ips)))
- ELSE IF (xidim .EQ. 2 .AND. xidim .NE. nsd) THEN
- aa = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 1, ips))
- bb = DOT_PRODUCT(obj%Jacobian(:, 2, ips), obj%Jacobian(:, 2, ips))
- ab = DOT_PRODUCT(obj%Jacobian(:, 1, ips), obj%Jacobian(:, 2, ips))
- obj%Js(ips) = SQRT(aa * bb - ab * ab)
- END IF
-END DO
+
+caseid = obj%xidim
+
+IF (obj%nsd .EQ. obj%xidim) THEN
+ caseid = 3
+END IF
+
+SELECT CASE (caseid)
+
+CASE (1)
+ DO ips = 1, obj%nips
+ obj%js(ips) = NORM2(obj%jacobian(1:obj%nsd, 1, ips))
+ END DO
+
+CASE (2)
+
+ DO ips = 1, obj%nips
+ aa = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), obj%jacobian(1:obj%nsd, 1, ips))
+ bb = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 2, ips), obj%jacobian(1:obj%nsd, 2, ips))
+ ab = DOT_PRODUCT(obj%jacobian(1:obj%nsd, 1, ips), obj%jacobian(1:obj%nsd, 2, ips))
+ obj%js(ips) = SQRT(aa * bb - ab * ab)
+ END DO
+
+CASE (3)
+
+ DO ips = 1, obj%nips
+ obj%js(ips) = Det(obj%jacobian(1:obj%nsd, 1:obj%xidim, ips))
+ END DO
+
+END SELECT
+
END PROCEDURE elemsd_SetJs
!----------------------------------------------------------------------------
@@ -88,24 +108,27 @@
MODULE PROCEDURE elemsd_SetdNdXt
! Define internal variables
-INTEGER(I4B) :: NSD, XiDim, ips, nips
-REAL(DFP), ALLOCATABLE :: InvJacobian(:, :, :)
-
-NSD = obj%RefElem%NSD
-XiDim = obj%RefElem%XiDimension
-IF (NSD .NE. XiDim) THEN
- obj%dNdXt = 0.0_DFP
-ELSE
- ! Compute inverse of Jacobian
- nips = SIZE(obj%N, 2)
- ALLOCATE (InvJacobian(NSD, NSD, nips))
- CALL Inv(InvA=InvJacobian, A=obj%Jacobian)
- DO ips = 1, nips
- obj%dNdXt(:, :, ips) = &
- & MATMUL(obj%dNdXi(:, :, ips), InvJacobian(:, :, ips))
- END DO
- DEALLOCATE (InvJacobian)
+INTEGER(I4B) :: ips
+
+REAL(DFP) :: invJacobian(3, 3)
+
+LOGICAL(LGT) :: abool
+
+abool = obj%nsd .NE. obj%xidim
+
+IF (abool) THEN
+ obj%dNdXt(1:obj%nns, 1:obj%nsd, 1:obj%nips) = 0.0_DFP
+ RETURN
END IF
+
+DO ips = 1, obj%nips
+ CALL Inv(InvA=invJacobian, A=obj%jacobian(1:obj%nsd, 1:obj%nsd, ips))
+
+ obj%dNdXt(1:obj%nns, 1:obj%nsd, ips) = &
+ MATMUL(obj%dNdXi(1:obj%nns, 1:obj%xidim, ips), &
+ invJacobian(1:obj%nsd, 1:obj%nsd))
+END DO
+
END PROCEDURE elemsd_SetdNdXt
!----------------------------------------------------------------------------
@@ -113,7 +136,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SetJacobian
-obj%jacobian = MATMUL(val, dNdXi)
+obj%jacobian(1:obj%nsd, 1:obj%xidim, 1:obj%nips) = MATMUL(val, dNdXi)
END PROCEDURE elemsd_SetJacobian
!----------------------------------------------------------------------------
@@ -129,17 +152,35 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE stsd_SetdNTdt
-REAL(DFP), ALLOCATABLE :: v(:, :)
-INTEGER(I4B) :: ip
+REAL(DFP), ALLOCATABLE :: v(:, :), mat2(:, :)
+REAL(DFP) :: areal
+
+INTEGER(I4B) :: ip, tsize
! get mesh velocity at space integration points
-v = MATMUL(MATMUL(val, obj%dTdTheta / obj%Jt), obj%N)
-CALL Reallocate(obj%dNTdt, SIZE(obj%N, 1), SIZE(obj%T), &
- & SIZE(obj%N, 2))
-DO ip = 1, SIZE(obj%N, 2)
- obj%dNTdt(:, :, ip) = OUTERPROD(obj%N(:, ip), obj%dTdTheta / obj%Jt) &
- & - MATMUL(obj%dNTdXt(:, :, :, ip), v(:, ip))
+
+! CALL Reallocate(obj%dNTdt, obj%nns, obj%nnt, obj%nips)
+areal = 1.0_DFP / obj%jt
+
+tsize = MAX(obj%nns, obj%nips)
+ALLOCATE (v(3, tsize), mat2(obj%nns, obj%nnt))
+
+v(1:obj%nsd, 1:obj%nns) = MATMUL(val, obj%dTdTheta)
+v(1:obj%nsd, 1:obj%nns) = v(1:obj%nsd, 1:obj%nns) * areal
+v(1:obj%nsd, 1:obj%nips) = MATMUL(v(1:obj%nsd, 1:obj%nns), &
+ obj%N(1:obj%nns, 1:obj%nips))
+
+DO ip = 1, obj%nips
+ mat2(1:obj%nns, 1:obj%nnt) = OUTERPROD(obj%N(1:obj%nns, ip), obj%dTdTheta(1:obj%nnt))
+ mat2 = mat2 * areal
+
+ obj%dNTdt(1:obj%nns, 1:obj%nnt, ip) = mat2 - &
+ MATMUL(obj%dNTdXt(1:obj%nns, 1:obj%nnt, 1:obj%nsd, ip), v(1:obj%nsd, ip))
+
END DO
+
+DEALLOCATE (v, mat2)
+
END PROCEDURE stsd_SetdNTdt
!----------------------------------------------------------------------------
@@ -147,29 +188,30 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE stsd_SetdNTdXt
-!
+REAL(DFP) :: Q(3, 3), temp(obj%nns, obj%nsd)
INTEGER(I4B) :: ip, j
-REAL(DFP), ALLOCATABLE :: Q(:, :), Temp(:, :)
-!
-CALL Reallocate(obj%dNTdXt, SIZE(obj%N, 1), SIZE(obj%T), &
- & SIZE(obj%Jacobian, 1), SIZE(obj%N, 2))
-!
-IF (obj%RefElem%XiDimension .NE. obj%RefElem%NSD) THEN
+
+CALL Reallocate(obj%dNTdXt, obj%nns, obj%nnt, obj%nsd, obj%nips)
+
+IF (obj%xidim .NE. obj%nsd) THEN
RETURN
END IF
-!
-Q = obj%Jacobian(:, :, 1)
-!
-DO ip = 1, SIZE(obj%N, 2)
- CALL INV(A=obj%Jacobian(:, :, ip), INVA=Q)
- Temp = MATMUL(obj%dNdXi(:, :, ip), Q)
- DO j = 1, SIZE(Q, 1)
- obj%dNTdXt(:, :, j, ip) = OUTERPROD(Temp(:, j), obj%T)
+
+DO ip = 1, obj%nips
+
+ CALL INV(A=obj%jacobian(1:obj%nsd, 1:obj%xidim, ip), &
+ INVA=Q(1:obj%nsd, 1:obj%nsd))
+
+ temp = MATMUL(obj%dNdXi(1:obj%nns, 1:obj%xidim, ip), &
+ Q(1:obj%nsd, 1:obj%nsd))
+
+ DO j = 1, obj%nsd
+ obj%dNTdXt(1:obj%nns, 1:obj%nnt, j, ip) = OUTERPROD(temp(1:obj%nns, j), &
+ obj%T(1:obj%nnt))
END DO
+
END DO
-!
-DEALLOCATE (Q, Temp)
-!
+
END PROCEDURE stsd_SetdNTdXt
!----------------------------------------------------------------------------
@@ -188,20 +230,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_Set2
-INTEGER(I4B), ALLOCATABLE :: facetNptrs(:)
-
CALL SetJacobian(obj=cellobj, val=cellVal, dNdXi=celldNdXi)
CALL SetJs(obj=cellobj)
CALL SetdNdXt(obj=cellobj)
CALL SetBarycentricCoord(obj=cellobj, val=cellval, N=cellN)
-facetNptrs = GetConnectivity(facetobj%refelem)
-
CALL SetJacobian(obj=facetobj, val=cellVal(:, facetNptrs), &
- & dNdXi=facetdNdXi)
+ dNdXi=facetdNdXi)
CALL SetJs(obj=facetobj)
CALL SetBarycentricCoord(obj=facetobj, val=cellval(:, facetNptrs), &
- & N=facetN)
+ N=facetN)
CALL SetNormal(obj=facetobj)
@@ -218,7 +256,6 @@
cellobj%Js = facetobj%Js
cellobj%Ws = facetobj%Ws
-IF (ALLOCATED(facetNptrs)) DEALLOCATE (facetNptrs)
END PROCEDURE elemsd_Set2
!----------------------------------------------------------------------------
@@ -234,7 +271,7 @@
& cellN=masterCellN, &
& celldNdXi=masterCelldNdXi, &
& facetN=masterFacetN, &
- & facetdNdXi=masterFacetdNdXi)
+ & facetdNdXi=masterFacetdNdXi, facetNptrs=masterFacetNptrs)
!
CALL Set( &
& facetobj=slaveFacetObj, &
@@ -243,7 +280,7 @@
& cellN=slaveCellN, &
& celldNdXi=slaveCelldNdXi, &
& facetN=slaveFacetN, &
- & facetdNdXi=slaveFacetdNdXi)
+ & facetdNdXi=slaveFacetdNdXi, facetNptrs=slaveFacetNptrs)
!
END PROCEDURE elemsd_Set3
@@ -267,14 +304,20 @@
MODULE PROCEDURE elemsd_SetNormal
REAL(DFP) :: vec(3, 3)
INTEGER(I4B) :: i, xidim, nsd
+
vec = 0.0_DFP
vec(3, 2) = 1.0_DFP
-xidim = obj%RefElem%XiDimension
-nsd = obj%refElem%nsd
-DO i = 1, SIZE(obj%N, 2)
- Vec(1:nsd, 1:xidim) = obj%Jacobian(1:nsd, 1:xidim, i)
- obj%Normal(:, i) = &
- & VectorProduct(Vec(:, 1), Vec(:, 2)) / obj%Js(i)
+
+xidim = obj%xidim
+
+nsd = obj%nsd
+
+DO i = 1, obj%nips
+
+ vec(1:nsd, 1:xidim) = obj%jacobian(1:nsd, 1:xidim, i)
+ obj%normal(1:3, i) = &
+ VectorProduct(vec(:, 1), vec(:, 2)) / obj%js(i)
+
END DO
END PROCEDURE elemsd_SetNormal
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90
index 07a7d5fae..15aa50970 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90
@@ -31,7 +31,7 @@
!! main
CALL getInterpolation(obj=obj, Val=val, Interpol=p)
CALL getSpatialGradient(obj=obj, lg=dp, Val=Val)
-CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2))
+CALL Reallocate(R, obj%nsd, obj%nips)
pnorm = NORM2(dp, DIM=1)
!!
DO ii = 1, SIZE(p)
@@ -66,7 +66,7 @@
!! get gradient of nodal values
CALL getSpatialGradient(obj=obj, lg=dp, Val=val)
pnorm = NORM2(p, DIM=1)
-CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2))
+CALL Reallocate(R, obj%nsd, obj%nips)
DO i = 1, SIZE(pnorm)
IF (pnorm(i) .GT. Zero) THEN
p(:, i) = p(:, i) / pnorm(i)
@@ -104,27 +104,27 @@ PURE SUBROUTINE scalar_getUnitNormal_3(obj, r, val)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :)
TYPE(FEVariable_), INTENT(IN) :: val
! Define internal variables
-REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:)
-INTEGER(I4B) :: ii
+ REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:)
+ INTEGER(I4B) :: ii
!! main
-CALL getInterpolation(obj=obj, Val=val, Interpol=p)
-CALL getSpatialGradient(obj=obj, lg=dp, Val=Val)
-CALL Reallocate(R, obj%refelem%NSD, SIZE(obj%N, 2))
-pnorm = NORM2(dp, DIM=1)
+ CALL getInterpolation(obj=obj, Val=val, Interpol=p)
+ CALL getSpatialGradient(obj=obj, lg=dp, Val=Val)
+ CALL Reallocate(R, obj%nsd, obj%nips)
+ pnorm = NORM2(dp, DIM=1)
!!
-DO ii = 1, SIZE(p)
- IF (pnorm(ii) .GT. zero) THEN
- IF (p(ii) .GE. 0.0_DFP) THEN
- R(:, ii) = dp(:, ii) / pnorm(ii)
- ELSE
- R(:, ii) = -dp(:, ii) / pnorm(ii)
+ DO ii = 1, SIZE(p)
+ IF (pnorm(ii) .GT. zero) THEN
+ IF (p(ii) .GE. 0.0_DFP) THEN
+ R(:, ii) = dp(:, ii) / pnorm(ii)
+ ELSE
+ R(:, ii) = -dp(:, ii) / pnorm(ii)
+ END IF
END IF
- END IF
-END DO
+ END DO
!!
-IF (ALLOCATED(dp)) DEALLOCATE (dp)
-IF (ALLOCATED(p)) DEALLOCATE (p)
-IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm)
+ IF (ALLOCATED(dp)) DEALLOCATE (dp)
+ IF (ALLOCATED(p)) DEALLOCATE (p)
+ IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm)
END SUBROUTINE scalar_getUnitNormal_3
!!
PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val)
@@ -132,35 +132,35 @@ PURE SUBROUTINE vector_getUnitNormal_3(obj, r, val)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: r(:, :)
TYPE(FEVariable_), INTENT(IN) :: val
!! Define internal variables
-REAL(DFP), ALLOCATABLE :: dp(:, :, :)
-REAL(DFP), ALLOCATABLE :: p(:, :)
-REAL(DFP), ALLOCATABLE :: mv(:)
-REAL(DFP), ALLOCATABLE :: pnorm(:)
-REAL(DFP) :: nrm
-INTEGER(I4B) :: i
+ REAL(DFP), ALLOCATABLE :: dp(:, :, :)
+ REAL(DFP), ALLOCATABLE :: p(:, :)
+ REAL(DFP), ALLOCATABLE :: mv(:)
+ REAL(DFP), ALLOCATABLE :: pnorm(:)
+ REAL(DFP) :: nrm
+ INTEGER(I4B) :: i
!! main
!! interpolate the vector
-CALL getInterpolation(obj=obj, Interpol=p, Val=val)
+ CALL getInterpolation(obj=obj, Interpol=p, Val=val)
!! get gradient of nodal values
-CALL getSpatialGradient(obj=obj, lg=dp, Val=val)
-pnorm = NORM2(p, DIM=1)
-CALL Reallocate(R, obj%RefElem%NSD, SIZE(obj%N, 2))
-DO i = 1, SIZE(pnorm)
- IF (pnorm(i) .GT. Zero) THEN
- p(:, i) = p(:, i) / pnorm(i)
- ELSE
- p(:, i) = 1.0
- END IF
- mv = MATMUL(p(:, i), dp(:, :, i))
- nrm = NORM2(mv)
- IF (nrm .GT. Zero) THEN
- R(:, i) = mv / nrm
- END IF
-END DO
-IF (ALLOCATED(dp)) DEALLOCATE (dp)
-IF (ALLOCATED(p)) DEALLOCATE (p)
-IF (ALLOCATED(mv)) DEALLOCATE (mv)
-IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm)
+ CALL getSpatialGradient(obj=obj, lg=dp, Val=val)
+ pnorm = NORM2(p, DIM=1)
+ CALL Reallocate(R, obj%nsd, obj%nips)
+ DO i = 1, SIZE(pnorm)
+ IF (pnorm(i) .GT. Zero) THEN
+ p(:, i) = p(:, i) / pnorm(i)
+ ELSE
+ p(:, i) = 1.0
+ END IF
+ mv = MATMUL(p(:, i), dp(:, :, i))
+ nrm = NORM2(mv)
+ IF (nrm .GT. Zero) THEN
+ R(:, i) = mv / nrm
+ END IF
+ END DO
+ IF (ALLOCATED(dp)) DEALLOCATE (dp)
+ IF (ALLOCATED(p)) DEALLOCATE (p)
+ IF (ALLOCATED(mv)) DEALLOCATE (mv)
+ IF (ALLOCATED(pnorm)) DEALLOCATE (pnorm)
END SUBROUTINE vector_getUnitNormal_3
!!
END PROCEDURE getUnitNormal_3
diff --git a/src/submodules/ElemshapeData/src/H1/CMakeLists.txt b/src/submodules/ElemshapeData/src/H1/CMakeLists.txt
new file mode 100644
index 000000000..d65a69823
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/H1/CMakeLists.txt
@@ -0,0 +1,24 @@
+# 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_path0 "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path0}/ElemshapeData_H1Methods@HermitMethods.F90
+ ${src_path0}/ElemshapeData_H1Methods@HierarchyMethods.F90
+ ${src_path0}/ElemshapeData_H1Methods@OrthogonalMethods.F90
+ ${src_path0}/ElemshapeData_H1Methods@SerendipityMethods.F90)
diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90
deleted file mode 100644
index 39cc8ade3..000000000
--- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@LagrangeMethods.F90
+++ /dev/null
@@ -1,133 +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
-!
-
-SUBMODULE(ElemShapeData_H1Methods) LagrangeMethods
-USE BaseMethod
-IMPLICIT NONE
-
-CONTAINS
-
-!----------------------------------------------------------------------------
-! Initiate
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE H1_Lagrange1
-REAL(DFP), ALLOCATABLE :: pt(:, :), xij(:, :), dNdXi(:, :, :), coeff0(:, :)
-INTEGER(I4B) :: nsd, xidim, ipType0, basisType0
-
-ipType0 = Input(default=Equidistance, option=ipType)
-basisType0 = Input(default=Monomial, option=basisType)
-
-! CALL DEALLOCATE (obj)
-CALL Initiate(obj%refelem, refelem)
-nsd = refelem%nsd
-xidim = refelem%xiDimension
-CALL GetQuadraturePoints(obj=quad, points=pt, weights=obj%ws)
-obj%quad = quad
-
-CALL ALLOCATE ( &
- & obj=obj, &
- & nsd=nsd, &
- & xidim=xidim, &
- & nns=LagrangeDOF(order=order, elemType=refelem%name), &
- & nips=SIZE(quad, 2))
-
-xij = InterpolationPoint( &
- & order=order, &
- & elemType=refelem%name, &
- & ipType=ipType0, &
- & layout="VEFC", &
- & xij=refelem%xij(1:xidim, :), &
- & alpha=alpha, beta=beta, lambda=lambda)
-
-CALL Reallocate(coeff0, SIZE(xij, 2), SIZE(xij, 2))
-
-IF (PRESENT(coeff)) THEN
- obj%N = TRANSPOSE(LagrangeEvalAll( &
- & order=order, &
- & elemType=refelem%name, &
- & x=pt(1:xidim, :), &
- & xij=xij, &
- & domainName=refelem%domainName, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & coeff=coeff, &
- & firstCall=firstCall))
-
- dNdXi = LagrangeGradientEvalAll( &
- & order=order, &
- & elemType=refelem%name, &
- & x=pt(1:xidim, :), &
- & xij=xij, &
- & domainName=refelem%domainName, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & coeff=coeff, &
- & firstCall=.FALSE.)
-
- CALL SWAP( &
- & a=obj%dNdXi, &
- & b=dNdXi, &
- & i1=2, i2=3, i3=1)
-
-ELSE
-
- obj%N = TRANSPOSE(LagrangeEvalAll( &
- & order=order, &
- & elemType=refelem%name, &
- & x=pt(1:xidim, :), &
- & xij=xij, &
- & domainName=refelem%domainName, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & coeff=coeff0, &
- & firstCall=.TRUE.))
-
- dNdXi = LagrangeGradientEvalAll( &
- & order=order, &
- & elemType=refelem%name, &
- & x=pt(1:xidim, :), &
- & xij=xij, &
- & domainName=refelem%domainName, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & coeff=coeff0, &
- & firstCall=.FALSE.)
-
- CALL SWAP( &
- & a=obj%dNdXi, &
- & b=dNdXi, &
- & i1=2, i2=3, i3=1)
-
-END IF
-
-IF (ALLOCATED(dNdXi)) DEALLOCATE (dNdXi)
-IF (ALLOCATED(xij)) DEALLOCATE (xij)
-IF (ALLOCATED(pt)) DEALLOCATE (pt)
-IF (ALLOCATED(coeff0)) DEALLOCATE (coeff0)
-
-END PROCEDURE H1_Lagrange1
-
-END SUBMODULE LagrangeMethods
diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HermitMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HermitMethods.F90
rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HermitMethods.F90
diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90
similarity index 97%
rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90
rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90
index 80d203300..002659362 100644
--- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@HierarchyMethods.F90
+++ b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@HierarchyMethods.F90
@@ -30,11 +30,9 @@
INTEGER(I4B) :: nsd, xidim
CALL DEALLOCATE (obj)
-CALL Initiate(obj%refelem, refelem)
nsd = refelem%nsd
xidim = refelem%xiDimension
CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws)
-obj%quad = quad
CALL ALLOCATE ( &
& obj=obj, &
@@ -50,7 +48,7 @@
& xij=xij, &
& refLine=refelem%domainName)
- dNdXi = HeirarchicalGradientBasis_Line( &
+ dNdXi = HeirarchicalBasisGradient_Line( &
& order=order, &
& xij=xij, &
& refLine=refelem%domainName)
diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90
similarity index 82%
rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90
rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90
index f104a5c00..870ec9bbe 100644
--- a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@OrthogonalMethods.F90
+++ b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@OrthogonalMethods.F90
@@ -32,11 +32,9 @@
basisType0 = Input(option=basisType, default=Legendre)
CALL DEALLOCATE (obj)
-CALL Initiate(obj%refelem, refelem)
nsd = refelem%nsd
xidim = refelem%xiDimension
CALL GetQuadraturePoints(obj=quad, points=xij, weights=obj%ws)
-obj%quad = quad
CALL ALLOCATE ( &
& obj=obj, &
@@ -79,12 +77,12 @@
& xij=xij, &
& basisType1=basisType0, &
& basisType2=basisType0, &
- & alpha1 = alpha, &
- & beta1 = beta, &
- & alpha2 = alpha, &
- & beta2 = beta, &
- & lambda1 = lambda, &
- & lambda2 = lambda )
+ & alpha1=alpha, &
+ & beta1=beta, &
+ & alpha2=alpha, &
+ & beta2=beta, &
+ & lambda1=lambda, &
+ & lambda2=lambda)
dNdXi = OrthogonalBasisGradient_Quadrangle( &
& p=order, &
@@ -92,12 +90,12 @@
& xij=xij, &
& basisType1=basisType0, &
& basisType2=basisType0, &
- & alpha1 = alpha, &
- & beta1 = beta, &
- & alpha2 = alpha, &
- & beta2 = beta, &
- & lambda1 = lambda, &
- & lambda2 = lambda )
+ & alpha1=alpha, &
+ & beta1=beta, &
+ & alpha2=alpha, &
+ & beta2=beta, &
+ & lambda1=lambda, &
+ & lambda2=lambda)
CASE (Tetrahedron)
N = OrthogonalBasis_Tetrahedron( &
@@ -119,15 +117,15 @@
& basisType1=basisType0, &
& basisType2=basisType0, &
& basisType3=basisType0, &
- & alpha1 = alpha, &
- & beta1 = beta, &
- & lambda1 = lambda, &
- & alpha2 = alpha, &
- & beta2 = beta, &
- & lambda2 = lambda, &
- & alpha3 = alpha, &
- & beta3 = beta, &
- & lambda3 = lambda &
+ & alpha1=alpha, &
+ & beta1=beta, &
+ & lambda1=lambda, &
+ & alpha2=alpha, &
+ & beta2=beta, &
+ & lambda2=lambda, &
+ & alpha3=alpha, &
+ & beta3=beta, &
+ & lambda3=lambda &
& )
dNdXi = OrthogonalBasisGradient_Hexahedron( &
@@ -138,15 +136,15 @@
& basisType1=basisType0, &
& basisType2=basisType0, &
& basisType3=basisType0, &
- & alpha1 = alpha, &
- & beta1 = beta, &
- & lambda1 = lambda, &
- & alpha2 = alpha, &
- & beta2 = beta, &
- & lambda2 = lambda, &
- & alpha3 = alpha, &
- & beta3 = beta, &
- & lambda3 = lambda &
+ & alpha1=alpha, &
+ & beta1=beta, &
+ & lambda1=lambda, &
+ & alpha2=alpha, &
+ & beta2=beta, &
+ & lambda2=lambda, &
+ & alpha3=alpha, &
+ & beta3=beta, &
+ & lambda3=lambda &
& )
CASE DEFAULT
diff --git a/src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@SerendipityMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/H1/ElemshapeData_H1Methods@SerendipityMethods.F90
rename to src/submodules/ElemshapeData/src/H1/src/ElemshapeData_H1Methods@SerendipityMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt b/src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt
new file mode 100644
index 000000000..9ab6dce6c
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/HCurl/CMakeLists.txt
@@ -0,0 +1,25 @@
+# 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_path0 "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path0}/ElemshapeData_HCurlMethods@HermitMethods.F90
+ ${src_path0}/ElemshapeData_HCurlMethods@HierarchyMethods.F90
+ ${src_path0}/ElemshapeData_HCurlMethods@LagrangeMethods.F90
+ ${src_path0}/ElemshapeData_HCurlMethods@OrthogonalMethods.F90
+ ${src_path0}/ElemshapeData_HCurlMethods@SerendipityMethods.F90)
diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HermitMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HermitMethods.F90
rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HermitMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HierarchyMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@HierarchyMethods.F90
rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@HierarchyMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@LagrangeMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@LagrangeMethods.F90
rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@LagrangeMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@OrthogonalMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@OrthogonalMethods.F90
rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@OrthogonalMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@SerendipityMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HCurl/ElemshapeData_HCurlMethods@SerendipityMethods.F90
rename to src/submodules/ElemshapeData/src/HCurl/src/ElemshapeData_HCurlMethods@SerendipityMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt b/src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt
new file mode 100644
index 000000000..fde44344d
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/HDiv/CMakeLists.txt
@@ -0,0 +1,25 @@
+# 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_path0 "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path0}/ElemshapeData_HDivMethods@HermitMethods.F90
+ ${src_path0}/ElemshapeData_HDivMethods@HierarchyMethods.F90
+ ${src_path0}/ElemshapeData_HDivMethods@LagrangeMethods.F90
+ ${src_path0}/ElemshapeData_HDivMethods@OrthogonalMethods.F90
+ ${src_path0}/ElemshapeData_HDivMethods@SerendipityMethods.F90)
diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HermitMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HermitMethods.F90
rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HermitMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HierarchyMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@HierarchyMethods.F90
rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@HierarchyMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@LagrangeMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@LagrangeMethods.F90
rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@LagrangeMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@OrthogonalMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@OrthogonalMethods.F90
rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@OrthogonalMethods.F90
diff --git a/src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90 b/src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@SerendipityMethods.F90
similarity index 100%
rename from src/submodules/ElemshapeData/src/HDiv/ElemshapeData_HDivMethods@SerendipityMethods.F90
rename to src/submodules/ElemshapeData/src/HDiv/src/ElemshapeData_HDivMethods@SerendipityMethods.F90
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90
index 30baa84be..6cecc69f9 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90
@@ -18,8 +18,21 @@
#define _ELEM_METHOD_ ABS
SUBMODULE(FEVariable_Method) AbsMethods
-USE BaseMethod
+
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -28,18 +41,18 @@
MODULE PROCEDURE fevar_Abs
SELECT CASE (obj%rank)
-!!
-CASE (SCALAR)
-#include "./ScalarElemMethod.inc"
-!!
-CASE (VECTOR)
-#include "./VectorElemMethod.inc"
-!!
-CASE (MATRIX)
-#include "./MatrixElemMethod.inc"
-!!
+
+CASE (scalar)
+#include "./include/ScalarElemMethod.F90"
+
+CASE (vector)
+#include "./include/VectorElemMethod.F90"
+
+CASE (matrix)
+#include "./include/MatrixElemMethod.F90"
+
END SELECT
-!!
+
END PROCEDURE fevar_Abs
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90
index 7efae1312..68d095928 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90
@@ -14,10 +14,24 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
-#define _OP_ +
SUBMODULE(FEVariable_Method) AdditionMethods
-USE BaseMethod
+
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE ReallocateUtility, ONLY: Reallocate
+
+#define _OP_ +
+
IMPLICIT NONE
CONTAINS
@@ -26,62 +40,33 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_addition1
-!!
-REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:)
+REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :)
INTEGER(I4B) :: jj, kk
-!!
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
- !!
- select case( obj2%rank )
- !! scalar, scalar
- case( scalar )
-#include "./ScalarOperatorScalar.inc"
- !! scalar, vector
- case( vector )
-#include "./ScalarOperatorVector.inc"
- !! scalar, matrix
- case( matrix )
-#include "./ScalarOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (VECTOR)
- !!
- select case( obj2%rank )
- !! vector, scalar
- case( scalar )
-#include "./VectorOperatorScalar.inc"
- !! vector, vector
- case( vector )
-#include "./VectorOperatorVector.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (MATRIX)
- !!
- select case( obj2%rank )
- case( scalar )
- !! matrix, scalar
-#include "./MatrixOperatorScalar.inc"
- case( matrix )
- !! matrix, matrix
-#include "./MatrixOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
+CASE (scalar)
+ SELECT CASE (obj2%rank)
+ CASE (scalar)
+#include "./include/ScalarOperatorScalar.F90"
+ CASE (vector)
+#include "./include/ScalarOperatorVector.F90"
+ CASE (matrix)
+#include "./include/ScalarOperatorMatrix.F90"
+ END SELECT
+CASE (vector)
+ SELECT CASE (obj2%rank)
+ CASE (scalar)
+#include "./include/VectorOperatorScalar.F90"
+ CASE (vector)
+#include "./include/VectorOperatorVector.F90"
+ END SELECT
+CASE (matrix)
+ SELECT CASE (obj2%rank)
+ CASE (scalar)
+#include "./include/MatrixOperatorScalar.F90"
+ CASE (matrix)
+#include "./include/MatrixOperatorMatrix.F90"
+ END SELECT
END SELECT
-!!
END PROCEDURE fevar_addition1
!----------------------------------------------------------------------------
@@ -90,30 +75,13 @@
MODULE PROCEDURE fevar_addition2
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
-#include "./ScalarOperatorReal.inc"
-!!
-!!
-!!
-!!
-CASE (VECTOR)
-#include "./VectorOperatorReal.inc"
-!!
-!!
-!!
-!!
-CASE (MATRIX)
-#include "./MatrixOperatorReal.inc"
-!!
-!!
-!!
-!!
+CASE (scalar)
+#include "./include/ScalarOperatorReal.F90"
+CASE (vector)
+#include "./include/VectorOperatorReal.F90"
+CASE (matrix)
+#include "./include/MatrixOperatorReal.F90"
END SELECT
-!!
END PROCEDURE fevar_addition2
!----------------------------------------------------------------------------
@@ -122,30 +90,13 @@
MODULE PROCEDURE fevar_addition3
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
-#include "./RealOperatorScalar.inc"
-!!
-!!
-!!
-!!
-CASE (VECTOR)
-#include "./RealOperatorVector.inc"
-!!
-!!
-!!
-!!
-CASE (MATRIX)
-#include "./RealOperatorMatrix.inc"
-!!
-!!
-!!
-!!
+CASE (scalar)
+#include "./include/RealOperatorScalar.F90"
+CASE (vector)
+#include "./include/RealOperatorVector.F90"
+CASE (matrix)
+#include "./include/RealOperatorMatrix.F90"
END SELECT
-!!
END PROCEDURE fevar_addition3
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90
index baa59dc5d..4cd019838 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90
@@ -16,7 +16,11 @@
!
SUBMODULE(FEVariable_Method) ConstructorMethods
-USE BaseMethod
+USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, &
+ Time, SpaceTime, Nodal, Quadrature
+
+USE ReallocateUtility, ONLY: Reallocate
+
IMPLICIT NONE
CONTAINS
@@ -27,9 +31,11 @@
MODULE PROCEDURE fevar_Deallocate
IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val)
obj%s = 0
-obj%DefineOn = 0
-obj%VarType = 0
-obj%Rank = 0
+obj%defineOn = 0
+obj%varType = 0
+obj%rank = 0
+obj%len = 0
+obj%capacity = 0
END PROCEDURE fevar_Deallocate
!----------------------------------------------------------------------------
@@ -37,11 +43,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Nodal_Scalar_Constant
-obj%val = [val]
-obj%s = 0
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = CONSTANT
+#define _DEFINEON_ Nodal
+#include "./include/scalar_constant.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Scalar_Constant
!----------------------------------------------------------------------------
@@ -49,11 +53,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Nodal_Scalar_Space
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = SPACE
+#define _DEFINEON_ Nodal
+#include "./include/scalar_space.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Scalar_Space
!----------------------------------------------------------------------------
@@ -61,35 +63,39 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Nodal_Scalar_Time
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = TIME
+#define _DEFINEON_ Nodal
+#include "./include/scalar_time.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Scalar_Time
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
-MODULE PROCEDURE Nodal_Scalar_Spacetime
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = SPACETIME
-END PROCEDURE Nodal_Scalar_Spacetime
+MODULE PROCEDURE Nodal_Scalar_SpaceTime
+#define _DEFINEON_ Nodal
+#include "./include/scalar_space_time.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Scalar_SpaceTime
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_SpaceTime2
+#define _DEFINEON_ Nodal
+#include "./include/scalar_space_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Scalar_SpaceTime2
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Nodal_Vector_Constant
-obj%val = val
-obj%s(1:1) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = VECTOR
-obj%vartype = CONSTANT
+#define _DEFINEON_ Nodal
+#include "./include/vector_constant.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Vector_Constant
!----------------------------------------------------------------------------
@@ -97,227 +103,365 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Nodal_Vector_Space
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = VECTOR
-obj%vartype = SPACE
+#define _DEFINEON_ Nodal
+#include "./include/vector_space.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Vector_Space
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
+MODULE PROCEDURE Nodal_Vector_Space2
+#define _DEFINEON_ Nodal
+#include "./include/vector_space2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Vector_Space2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE Nodal_Vector_Time
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = VECTOR
-obj%vartype = TIME
+#define _DEFINEON_ Nodal
+#include "./include/vector_time.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Vector_Time
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
-MODULE PROCEDURE Nodal_Vector_Spacetime
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:3) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = VECTOR
-obj%vartype = SPACETIME
-END PROCEDURE Nodal_Vector_Spacetime
+MODULE PROCEDURE Nodal_Vector_Time2
+#define _DEFINEON_ Nodal
+#include "./include/vector_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Vector_Time2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_SpaceTime
+#define _DEFINEON_ Nodal
+#include "./include/vector_space_time.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Vector_SpaceTime
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_SpaceTime2
+#define _DEFINEON_ Nodal
+#include "./include/vector_space_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Vector_SpaceTime2
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Nodal_Matrix_Constant
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = MATRIX
-obj%vartype = CONSTANT
+#define _DEFINEON_ Nodal
+#include "./include/matrix_constant.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Matrix_Constant
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
+MODULE PROCEDURE Nodal_Matrix_Constant2
+#define _DEFINEON_ Nodal
+#include "./include/matrix_constant2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Matrix_Constant2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE Nodal_Matrix_Space
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:3) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = MATRIX
-obj%vartype = SPACE
+#define _DEFINEON_ Nodal
+#include "./include/matrix_space.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Matrix_Space
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
+MODULE PROCEDURE Nodal_Matrix_Space2
+#define _DEFINEON_ Nodal
+#include "./include/matrix_space2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Matrix_Space2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE Nodal_Matrix_Time
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:3) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = MATRIX
-obj%vartype = TIME
+#define _DEFINEON_ Nodal
+#include "./include/matrix_time.F90"
+#undef _DEFINEON_
END PROCEDURE Nodal_Matrix_Time
!----------------------------------------------------------------------------
! NodalVariable
!----------------------------------------------------------------------------
-MODULE PROCEDURE Nodal_Matrix_Spacetime
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:4) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = MATRIX
-obj%vartype = SPACETIME
-END PROCEDURE Nodal_Matrix_Spacetime
+MODULE PROCEDURE Nodal_Matrix_Time2
+#define _DEFINEON_ Nodal
+#include "./include/matrix_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Matrix_Time2
!----------------------------------------------------------------------------
-! QuadratureVariable
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_SpaceTime
+#define _DEFINEON_ Nodal
+#include "./include/matrix_space_time.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Matrix_SpaceTime
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_SpaceTime2
+#define _DEFINEON_ Nodal
+#include "./include/matrix_space_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Nodal_Matrix_SpaceTime2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Scalar_Constant
-obj%val = [val]
-obj%s = 0
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = CONSTANT
+#define _DEFINEON_ Quadrature
+#include "./include/scalar_constant.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Scalar_Constant
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Scalar_Space
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = SPACE
+#define _DEFINEON_ Quadrature
+#include "./include/scalar_space.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Scalar_Space
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Scalar_Time
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = TIME
+#define _DEFINEON_ Quadrature
+#include "./include/scalar_time.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Scalar_Time
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
!----------------------------------------------------------------------------
-MODULE PROCEDURE Quadrature_Scalar_Spacetime
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = SPACETIME
-END PROCEDURE Quadrature_Scalar_Spacetime
+MODULE PROCEDURE Quadrature_Scalar_SpaceTime
+#define _DEFINEON_ Quadrature
+#include "./include/scalar_space_time.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Scalar_SpaceTime
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_SpaceTime2
+#define _DEFINEON_ Quadrature
+#include "./include/scalar_space_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Scalar_SpaceTime2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Vector_Constant
-obj%val = val
-obj%s(1:1) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = VECTOR
-obj%vartype = CONSTANT
+#define _DEFINEON_ Quadrature
+#include "./include/vector_constant.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Vector_Constant
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Vector_Space
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = VECTOR
-obj%vartype = SPACE
+#define _DEFINEON_ Quadrature
+#include "./include/vector_space.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Vector_Space
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Space2
+#define _DEFINEON_ Quadrature
+#include "./include/vector_space2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Vector_Space2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Vector_Time
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = VECTOR
-obj%vartype = TIME
+#define _DEFINEON_ Quadrature
+#include "./include/vector_time.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Vector_Time
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Time2
+#define _DEFINEON_ Quadrature
+#include "./include/vector_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Vector_Time2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_SpaceTime
+#define _DEFINEON_ Quadrature
+#include "./include/vector_space_time.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Vector_SpaceTime
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
-MODULE PROCEDURE Quadrature_Vector_Spacetime
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:3) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = VECTOR
-obj%vartype = SPACETIME
-END PROCEDURE Quadrature_Vector_Spacetime
+MODULE PROCEDURE Quadrature_Vector_SpaceTime2
+#define _DEFINEON_ Quadrature
+#include "./include/vector_space_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Vector_SpaceTime2
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Matrix_Constant
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:2) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = MATRIX
-obj%vartype = CONSTANT
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_constant.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Matrix_Constant
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Constant2
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_constant2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Matrix_Constant2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Matrix_Space
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:3) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = MATRIX
-obj%vartype = SPACE
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_space.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Matrix_Space
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Space2
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_space2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Matrix_Space2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
MODULE PROCEDURE Quadrature_Matrix_Time
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:3) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = MATRIX
-obj%vartype = TIME
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_time.F90"
+#undef _DEFINEON_
END PROCEDURE Quadrature_Matrix_Time
!----------------------------------------------------------------------------
-! QuadratureVariable
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Time2
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Matrix_Time2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
!----------------------------------------------------------------------------
-MODULE PROCEDURE Quadrature_Matrix_Spacetime
-obj%val = RESHAPE(val, [SIZE(val)])
-obj%s(1:4) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = MATRIX
-obj%vartype = SPACETIME
-END PROCEDURE Quadrature_Matrix_Spacetime
+MODULE PROCEDURE Quadrature_Matrix_SpaceTime
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_space_time.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Matrix_SpaceTime
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_SpaceTime2
+#define _DEFINEON_ Quadrature
+#include "./include/matrix_space_time2.F90"
+#undef _DEFINEON_
+END PROCEDURE Quadrature_Matrix_SpaceTime2
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy
+obj1%s = obj2%s
+obj1%defineOn = obj2%defineOn
+obj1%rank = obj2%rank
+obj1%varType = obj2%varType
+obj1%len = obj2%len
+
+IF (obj1%capacity .GE. obj1%len) THEN
+ obj1%val(1:obj1%len) = obj2%val(1:obj1%len)
+ RETURN
+END IF
+
+obj1%capacity = CAPACITY_EXPAND_FACTOR * obj1%len
+CALL Reallocate(obj1%val, obj1%capacity)
+obj1%val(1:obj1%len) = obj2%val(1:obj1%len)
+
+END PROCEDURE obj_Copy
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END SUBMODULE ConstructorMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90
index 2bf089160..3046f33bf 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90
@@ -14,11 +14,25 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
-#define _OP_ /
SUBMODULE(FEVariable_Method) DivisionMethods
-USE BaseMethod
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE ReallocateUtility, ONLY: Reallocate
+
+#define _OP_ /
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -26,62 +40,47 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Division1
-!!
-REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:)
+REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :)
INTEGER(I4B) :: jj, kk
-!!
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
- !!
- select case( obj2%rank )
- !! scalar, scalar
- case( scalar )
-#include "./ScalarOperatorScalar.inc"
- !! scalar, vector
- case( vector )
-#include "./ScalarOperatorVector.inc"
- !! scalar, matrix
- case( matrix )
-#include "./ScalarOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (VECTOR)
- !!
- select case( obj2%rank )
- !! vector, scalar
- case( scalar )
-#include "./VectorOperatorScalar.inc"
- !! vector, vector
- case( vector )
-#include "./VectorOperatorVector.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (MATRIX)
- !!
- select case( obj2%rank )
- case( scalar )
- !! matrix, scalar
-#include "./MatrixOperatorScalar.inc"
- case( matrix )
- !! matrix, matrix
-#include "./MatrixOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
+
+CASE (scalar)
+
+ SELECT CASE (obj2%rank)
+
+ CASE (scalar)
+
+#include "./include/ScalarOperatorScalar.F90"
+ CASE (vector)
+
+#include "./include/ScalarOperatorVector.F90"
+ CASE (matrix)
+
+#include "./include/ScalarOperatorMatrix.F90"
+ END SELECT
+CASE (vector)
+
+ SELECT CASE (obj2%rank)
+
+ CASE (scalar)
+
+#include "./include/VectorOperatorScalar.F90"
+ CASE (vector)
+
+#include "./include/VectorOperatorVector.F90"
+ END SELECT
+CASE (matrix)
+
+ SELECT CASE (obj2%rank)
+
+ CASE (scalar)
+
+#include "./include/MatrixOperatorScalar.F90"
+ CASE (matrix)
+
+#include "./include/MatrixOperatorMatrix.F90"
+ END SELECT
END SELECT
-!!
END PROCEDURE fevar_Division1
!----------------------------------------------------------------------------
@@ -90,30 +89,17 @@
MODULE PROCEDURE fevar_Division2
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
-#include "./ScalarOperatorReal.inc"
-!!
-!!
-!!
-!!
-CASE (VECTOR)
-#include "./VectorOperatorReal.inc"
-!!
-!!
-!!
-!!
-CASE (MATRIX)
-#include "./MatrixOperatorReal.inc"
-!!
-!!
-!!
-!!
+
+CASE (scalar)
+
+#include "./include/ScalarOperatorReal.F90"
+CASE (vector)
+
+#include "./include/VectorOperatorReal.F90"
+CASE (matrix)
+
+#include "./include/MatrixOperatorReal.F90"
END SELECT
-!!
END PROCEDURE fevar_Division2
!----------------------------------------------------------------------------
@@ -122,35 +108,22 @@
MODULE PROCEDURE fevar_Division3
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
-#include "./RealOperatorScalar.inc"
-!!
-!!
-!!
-!!
-CASE (VECTOR)
-#include "./RealOperatorVector.inc"
-!!
-!!
-!!
-!!
-CASE (MATRIX)
-#include "./RealOperatorMatrix.inc"
-!!
-!!
-!!
-!!
+
+CASE (scalar)
+
+#include "./include/RealOperatorScalar.F90"
+CASE (vector)
+
+#include "./include/RealOperatorVector.F90"
+CASE (matrix)
+
+#include "./include/RealOperatorMatrix.F90"
END SELECT
-!!
END PROCEDURE fevar_Division3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-END SUBMODULE DivisionMethods
#undef _OP_
+END SUBMODULE DivisionMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90
index a23c6c040..d7e92e320 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90
@@ -16,7 +16,8 @@
!
SUBMODULE(FEVariable_Method) EqualMethods
-USE BaseMethod
+USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.)
+
IMPLICIT NONE
CONTAINS
@@ -27,11 +28,13 @@
MODULE PROCEDURE fevar_isequal
!! Internal variable
ans = .FALSE.
-IF( ALL(obj1%val .APPROXEQ. obj2%val) ) ans = .TRUE.
-IF( obj1%defineon .ne. obj2%defineon ) ans = .FALSE.
-IF( obj1%rank .ne. obj2%rank ) ans = .FALSE.
-IF( obj1%varType .ne. obj2%varType ) ans = .FALSE.
-IF( ANY(obj1%s .NE. obj2%s) ) ans = .FALSE.
+IF (obj1%len .NE. obj2%len) RETURN
+IF (obj1%defineon .NE. obj2%defineon) RETURN
+IF (obj1%rank .NE. obj2%rank) RETURN
+IF (obj1%varType .NE. obj2%varType) RETURN
+IF (ANY(obj1%s .NE. obj2%s)) RETURN
+
+IF (ALL(obj1%val(1:obj1%len) .APPROXEQ.obj2%val(1:obj2%len))) ans = .TRUE.
!!
END PROCEDURE fevar_isequal
@@ -40,33 +43,32 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_notEqual
-!! Internal variable
ans = .FALSE.
-IF( .NOT. ALL(obj1%val .APPROXEQ. obj2%val) ) THEN
+IF (.NOT. ALL(obj1%val.APPROXEQ.obj2%val)) THEN
ans = .TRUE.
RETURN
END IF
-!!
-IF( obj1%defineon .ne. obj2%defineon ) THEN
+
+IF (obj1%defineon .NE. obj2%defineon) THEN
ans = .TRUE.
RETURN
END IF
-!!
-IF( obj1%rank .ne. obj2%rank ) THEN
+
+IF (obj1%rank .NE. obj2%rank) THEN
ans = .TRUE.
RETURN
END IF
-!!
-IF( obj1%varType .ne. obj2%varType ) THEN
+
+IF (obj1%varType .NE. obj2%varType) THEN
ans = .TRUE.
RETURN
END IF
-!!
-IF( ANY(obj1%s .NE. obj2%s) ) THEN
+
+IF (ANY(obj1%s .NE. obj2%s)) THEN
ans = .TRUE.
RETURN
END IF
-!!
+
END PROCEDURE fevar_notEqual
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90
index fe72dd320..dc39463e2 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90
@@ -15,8 +15,13 @@
! along with this program. If not, see
SUBMODULE(FEVariable_Method) GetMethods
-USE BaseMethod, ONLY: Reallocate
+
+USE ReallocateUtility, ONLY: Reallocate
+
+USE GlobalData, ONLY: Scalar, Vector, Matrix, Constant, Space, &
+ Time, SpaceTime, Nodal, Quadrature
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -24,29 +29,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_GetLambdaFromYoungsModulus
-INTEGER(I4B) :: tsize, ii
-LOGICAL(LGT) :: isok
-
-isok = ALLOCATED(youngsModulus%val)
-
-IF (isok) THEN
- tsize = SIZE(youngsModulus%val)
-ELSE
- tsize = 0
-END IF
+INTEGER(I4B) :: ii
-CALL Reallocate(lambda%val, tsize)
+lambda = youngsModulus
-DO ii = 1, tsize
- lambda%val(1:tsize) = shearModulus%val * &
- & (youngsModulus%val - 2.0_DFP * shearModulus%val) / &
- & (3.0_DFP * shearModulus%val - youngsModulus%val)
+DO CONCURRENT(ii=1:lambda%len)
+ lambda%val(ii) = shearModulus%val(ii) * &
+ (youngsModulus%val(ii) - 2.0_DFP * shearModulus%val(ii)) / &
+ (3.0_DFP * shearModulus%val(ii) - youngsModulus%val(ii))
END DO
-lambda%s = youngsModulus%s
-lambda%defineOn = youngsModulus%defineOn
-lambda%varType = youngsModulus%varType
-lambda%rank = youngsModulus%rank
END PROCEDURE fevar_GetLambdaFromYoungsModulus
!----------------------------------------------------------------------------
@@ -57,14 +49,7 @@
IF (PRESENT(dim)) THEN
ans = obj%s(dim)
ELSE
- SELECT CASE (obj%rank)
- CASE (Scalar)
- ans = 1
- CASE (Vector)
- ans = obj%s(1)
- CASE (Matrix)
- ans = obj%s(1) * obj%s(2)
- END SELECT
+ ans = obj%len
END IF
END PROCEDURE fevar_Size
@@ -133,11 +118,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_isNodalVariable
-IF (obj%defineon .EQ. nodal) THEN
- ans = .TRUE.
-ELSE
- ans = .FALSE.
-END IF
+ans = obj%defineon .EQ. nodal
END PROCEDURE fevar_isNodalVariable
!----------------------------------------------------------------------------
@@ -145,11 +126,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_isQuadratureVariable
-IF (obj%defineon .EQ. nodal) THEN
- ans = .FALSE.
-ELSE
- ans = .TRUE.
-END IF
+ans = obj%defineon .NE. nodal
END PROCEDURE fevar_isQuadratureVariable
!----------------------------------------------------------------------------
@@ -160,96 +137,361 @@
val = obj%val(1)
END PROCEDURE Scalar_Constant
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE Master_Get_vec_(obj, val, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+
+ tsize = obj%len
+ val(1:tsize) = obj%val(1:tsize)
+
+END SUBROUTINE Master_Get_vec_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE Master_Get_mat_(obj, val, nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ INTEGER(I4B) :: ii, jj, cnt
+
+ nrow = obj%s(1)
+ ncol = obj%s(2)
+
+ cnt = 0
+ DO jj = 1, ncol
+ DO ii = 1, nrow
+ cnt = cnt + 1
+ val(ii, jj) = obj%val(cnt)
+ END DO
+ END DO
+END SUBROUTINE Master_Get_mat_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE Master_get_mat3_(obj, val, dim1, dim2, dim3)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ INTEGER(I4B) :: ii, jj, kk, cnt
+
+ dim1 = obj%s(1)
+ dim2 = obj%s(2)
+ dim3 = obj%s(3)
+
+ cnt = 0
+ DO kk = 1, dim3
+ DO jj = 1, dim2
+ DO ii = 1, dim1
+ cnt = cnt + 1
+ val(ii, jj, kk) = obj%val(cnt)
+ END DO
+ END DO
+ END DO
+
+END SUBROUTINE Master_get_mat3_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Scalar_Space
-val = obj%val
+ALLOCATE (val(obj%len))
+val = obj%val(1:obj%len)
END PROCEDURE Scalar_Space
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Space_
+CALL Master_Get_vec_(obj, val, tsize)
+END PROCEDURE Scalar_Space_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Scalar_Time
-val = obj%val
+ALLOCATE (val(obj%len))
+val = obj%val(1:obj%len)
END PROCEDURE Scalar_Time
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Time_
+CALL Master_Get_vec_(obj, val, tsize)
+END PROCEDURE Scalar_Time_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Scalar_SpaceTime
-val = RESHAPE(obj%val, obj%s(1:2))
+INTEGER(I4B) :: ii, jj, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2)))
+
+cnt = 0
+DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj) = obj%val(cnt)
+
+ END DO
+END DO
+
END PROCEDURE Scalar_SpaceTime
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_SpaceTime_
+CALL Master_Get_mat_(obj, val, nrow, ncol)
+END PROCEDURE Scalar_SpaceTime_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Vector_Constant
-val = obj%val
+ALLOCATE (val(obj%len))
+val = obj%val(1:obj%len)
END PROCEDURE Vector_Constant
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Constant_
+CALL Master_Get_vec_(obj, val, tsize)
+END PROCEDURE Vector_Constant_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Vector_Space
-val = RESHAPE(obj%val, obj%s(1:2))
+INTEGER(I4B) :: ii, jj, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2)))
+
+cnt = 0
+DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj) = obj%val(cnt)
+ END DO
+END DO
+
END PROCEDURE Vector_Space
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Space_
+CALL Master_Get_mat_(obj, val, nrow, ncol)
+END PROCEDURE Vector_Space_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Vector_Time
-val = RESHAPE(obj%val, obj%s(1:2))
+INTEGER(I4B) :: ii, jj, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2)))
+
+cnt = 0
+DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj) = obj%val(cnt)
+ END DO
+END DO
END PROCEDURE Vector_Time
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Time_
+CALL Master_Get_mat_(obj, val, nrow, ncol)
+END PROCEDURE Vector_Time_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Vector_SpaceTime
-val = RESHAPE(obj%val, obj%s(1:3))
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3)))
+
+cnt = 0
+DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj, kk) = obj%val(cnt)
+ END DO
+ END DO
+END DO
END PROCEDURE Vector_SpaceTime
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_SpaceTime_
+CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3)
+END PROCEDURE Vector_SpaceTime_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Matrix_Constant
-val = RESHAPE(obj%val, obj%s(1:2))
+INTEGER(I4B) :: ii, jj, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2)))
+
+cnt = 0
+DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj) = obj%val(cnt)
+ END DO
+END DO
END PROCEDURE Matrix_Constant
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Constant_
+CALL Master_Get_mat_(obj, val, nrow, ncol)
+END PROCEDURE Matrix_Constant_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Matrix_Space
-val = RESHAPE(obj%val, obj%s(1:3))
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3)))
+
+cnt = 0
+DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj, kk) = obj%val(cnt)
+ END DO
+ END DO
+END DO
END PROCEDURE Matrix_Space
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Space_
+CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3)
+END PROCEDURE Matrix_Space_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Matrix_Time
-val = RESHAPE(obj%val, obj%s(1:3))
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3)))
+
+cnt = 0
+DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj, kk) = obj%val(cnt)
+ END DO
+ END DO
+END DO
END PROCEDURE Matrix_Time
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Time_
+CALL Master_Get_mat3_(obj, val, dim1, dim2, dim3)
+END PROCEDURE Matrix_Time_
+
!----------------------------------------------------------------------------
! getNodalvalues
!----------------------------------------------------------------------------
MODULE PROCEDURE Matrix_SpaceTime
-val = RESHAPE(obj%val, obj%s(1:4))
+INTEGER(I4B) :: ii, jj, kk, ll, cnt
+
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4)))
+
+cnt = 0
+DO ll = 1, obj%s(4)
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ val(ii, jj, kk, ll) = obj%val(cnt)
+ END DO
+ END DO
+ END DO
+END DO
END PROCEDURE Matrix_SpaceTime
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+MODULE PROCEDURE Matrix_SpaceTime_
+INTEGER(I4B) :: ii, jj, kk, ll, cnt
+
+dim1 = obj%s(1)
+dim2 = obj%s(2)
+dim3 = obj%s(3)
+dim4 = obj%s(4)
+
+cnt = 0
+DO ll = 1, dim4
+ DO kk = 1, dim3
+ DO jj = 1, dim2
+ DO ii = 1, dim1
+ cnt = cnt + 1
+ val(ii, jj, kk, ll) = obj%val(cnt)
+ END DO
+ END DO
+ END DO
+END DO
+
+END PROCEDURE Matrix_SpaceTime_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END SUBMODULE GetMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90
index 8afea2cb1..276dd37c0 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90
@@ -16,106 +16,123 @@
!
SUBMODULE(FEVariable_Method) IOMethods
-USE BaseMethod
+USE Display_Method, ONLY: Util_Display => Display, ToString
+
+USE GlobalData, ONLY: Scalar, Vector, Matrix, &
+ Constant, Space, Time, SpaceTime, &
+ Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime, &
+ TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix
+
+USE SafeSizeUtility, ONLY: SafeSize
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
-! Display
+! Display
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Display
-!!
-!! main
-!!
-CALL Display(msg, unitno=unitno)
-!!
+CALL Util_Display(msg, unitno=unitno)
+
SELECT CASE (obj%rank)
-!!
-!! rank: SCALAR
-!!
-CASE (SCALAR)
- CALL Display("# RANK :: 0 (SCALAR)", unitno=unitno)
- !!
- SELECT CASE (obj%vartype)
- CASE (CONSTANT)
- CALL Display("# VarType: CONSTANT", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableConstant), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (SPACE)
- CALL Display("# VarType: SPACE", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableSpace), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (TIME)
- CALL Display("# VarType: TIME", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableTime), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (SPACETIME)
- CALL Display("# VarType: SPACE & TIME", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableScalar, typeFEVariableSpaceTime), &
- & '# VALUE: ', unitno=unitno)
+
+CASE (Scalar)
+
+ CALL Util_Display("RANK :: 0 (Scalar)", unitno=unitno)
+
+ SELECT CASE (obj%varType)
+ CASE (Constant)
+ CALL Util_Display("VarType: Constant", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableConstant), &
+ 'VALUE: ', unitno=unitno)
+
+ CASE (Space)
+ CALL Util_Display("VarType: Space", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpace), &
+ 'VALUE: ', unitno=unitno)
+ CASE (Time)
+ CALL Util_Display("VarType: Time", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableTime), &
+ 'VALUE: ', unitno=unitno)
+ CASE (SpaceTime)
+ CALL Util_Display("VarType: Space & Time", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableScalar, TypeFEVariableSpaceTime), &
+ 'VALUE: ', unitno=unitno)
+
+ CASE DEFAULT
+ CALL Util_Display("VarType: UNKNOWN", unitno=unitno)
END SELECT
-!!
-!! rank: VECTOR
-!!
-CASE (VECTOR)
- !!
- CALL Display("RANK :: 1 (VECTOR)", unitno=unitno)
- !!
- SELECT CASE (obj%vartype)
- CASE (CONSTANT)
- CALL Display("# VarType: CONSTANT", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableVector, typeFEVariableConstant), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (SPACE)
- CALL Display("# VarType: SPACE", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableVector, typeFEVariableSpace), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (TIME)
- CALL Display("# VarType: TIME", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableVector, typeFEVariableTime), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (SPACETIME)
- CALL Display("# VarType: SPACE & TIME", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableVector, typeFEVariableSpaceTime), &
- & '# VALUE: ', unitno=unitno)
+
+CASE (Vector)
+
+ CALL Util_Display("RANK :: 1 (Vector)", unitno=unitno)
+ SELECT CASE (obj%varType)
+ CASE (Constant)
+ CALL Util_Display("VarType: Constant", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableConstant), &
+ 'VALUE: ', unitno=unitno)
+ CASE (Space)
+ CALL Util_Display("VarType: Space", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpace), &
+ 'VALUE: ', unitno=unitno)
+ CASE (Time)
+ CALL Util_Display("VarType: Time", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableTime), &
+ 'VALUE: ', unitno=unitno)
+ CASE (SpaceTime)
+ CALL Util_Display("VarType: Space & Time", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime), &
+ 'VALUE: ', unitno=unitno)
+
+ CASE DEFAULT
+ CALL Util_Display("VarType: UNKNOWN", unitno=unitno)
END SELECT
-!!
-!! rank: MATRIX
-!!
-CASE (MATRIX)
- !!
- CALL Display("RANK :: 2 (MATRIX)", unitno=unitno)
- !!
- SELECT CASE (obj%vartype)
- CASE (CONSTANT)
- CALL Display("# VarType: CONSTANT", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableConstant), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (SPACE)
- CALL Display("# VarType: SPACE", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableSpace), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (TIME)
- CALL Display("# VarType: TIME", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableTime), &
- & '# VALUE: ', unitno=unitno)
- !!
- CASE (SPACETIME)
- CALL Display("# VarType: SPACE & TIME", unitno=unitno)
- CALL Display(GET(obj, typeFEVariableMatrix, typeFEVariableSpaceTime), &
- & '# VALUE: ', unitno=unitno)
+
+CASE (Matrix)
+
+ CALL Util_Display("RANK :: 2 (Matrix)", unitno=unitno)
+ SELECT CASE (obj%varType)
+ CASE (Constant)
+ CALL Util_Display("VarType: Constant", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableConstant), &
+ 'VALUE: ', unitno=unitno)
+ CASE (Space)
+ CALL Util_Display("VarType: Space", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpace), &
+ 'VALUE: ', unitno=unitno)
+ CASE (Time)
+ CALL Util_Display("VarType: Time", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableTime), &
+ 'VALUE: ', unitno=unitno)
+ CASE (SpaceTime)
+ CALL Util_Display("VarType: Space & Time", unitno=unitno)
+ CALL Util_Display(GET(obj, TypeFEVariableMatrix, TypeFEVariableSpaceTime), &
+ 'VALUE: ', unitno=unitno)
+
+ CASE DEFAULT
+ CALL Util_Display("VarType: UNKNOWN", unitno=unitno)
END SELECT
+
+CASE DEFAULT
+ CALL Util_Display("RANK: UNKNOWN", unitno=unitno)
+
END SELECT
-!!
+
+CALL Util_Display(obj%s, "s: ", unitno=unitno)
+CALL Util_Display(obj%defineOn, "defineOn: ", unitno=unitno)
+CALL Util_Display(obj%len, "len: ", unitno=unitno)
+CALL Util_Display(obj%capacity, "capacity: ", unitno=unitno)
+CALL Util_Display(SafeSize(obj%val), "Size of obj%val: ", unitno=unitno)
+
END PROCEDURE fevar_Display
END SUBMODULE IOMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90
index e136ab97b..979dc3e8f 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90
@@ -16,7 +16,20 @@
!
SUBMODULE(FEVariable_Method) MeanMethods
-USE BaseMethod
+USE IntegerUtility, ONLY: Get1DIndexFortran
+
+USE GlobalData, ONLY: Scalar, Vector, Matrix, &
+ Constant, Space, Time, &
+ SpaceTime, Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
IMPLICIT NONE
CONTAINS
@@ -25,53 +38,35 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Mean1
- REAL( DFP ) :: val0
- REAL( DFP ), ALLOCATABLE :: val1( : ), val2( :, : )
- !!
- SELECT CASE (obj%rank)
- !!
- !! Scalar
- !!
- CASE (SCALAR)
- !!
- IF( obj%defineOn .EQ. NODAL ) THEN
- ans = NodalVariable( MEAN( obj, TypeFEVariableScalar ), &
- & TypeFEVariableScalar, &
- & TypeFEVariableConstant )
- ELSE
- ans = QuadratureVariable( MEAN( obj, TypeFEVariableScalar ), &
- & TypeFEVariableScalar, &
- & TypeFEVariableConstant )
- END IF
- !!
- !! Vector
- !!
- CASE (VECTOR)
- !!
- IF( obj%defineOn .EQ. NODAL ) THEN
- ans = NodalVariable( MEAN( obj, TypeFEVariableVector ), &
- & TypeFEVariableVector, &
- & TypeFEVariableConstant )
- ELSE
- ans = QuadratureVariable( MEAN( obj, TypeFEVariableVector ), &
- & TypeFEVariableVector, &
- & TypeFEVariableConstant )
- END IF
- !!
- CASE (MATRIX)
- !!
- IF( obj%defineOn .EQ. NODAL ) THEN
- ans = NodalVariable( MEAN( obj, TypeFEVariableMatrix ), &
- & TypeFEVariableMatrix, &
- & TypeFEVariableConstant )
- ELSE
- ans = QuadratureVariable( MEAN( obj, TypeFEVariableMatrix ), &
- & TypeFEVariableMatrix, &
- & TypeFEVariableConstant )
- END IF
- !!
- END SELECT
- !!
+REAL(DFP) :: val0
+SELECT CASE (obj%rank)
+CASE (scalar)
+ IF (obj%defineOn .EQ. NODAL) THEN
+ ans = NodalVariable(MEAN(obj, TypeFEVariableScalar), TypeFEVariableScalar, &
+ TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(MEAN(obj, TypeFEVariableScalar), &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ END IF
+
+CASE (vector)
+ IF (obj%defineOn .EQ. NODAL) THEN
+ ans = NodalVariable(MEAN(obj, TypeFEVariableVector), &
+ TypeFEVariableVector, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(MEAN(obj, TypeFEVariableVector), &
+ TypeFEVariableVector, TypeFEVariableConstant)
+ END IF
+
+CASE (matrix)
+ IF (obj%defineOn .EQ. NODAL) THEN
+ ans = NodalVariable(MEAN(obj, TypeFEVariableMatrix), &
+ TypeFEVariableMatrix, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(MEAN(obj, TypeFEVariableMatrix), &
+ TypeFEVariableMatrix, TypeFEVariableConstant)
+ END IF
+END SELECT
END PROCEDURE fevar_Mean1
!----------------------------------------------------------------------------
@@ -79,10 +74,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Mean2
- REAL( DFP ) :: val0
- !!
- ans = SUM( obj%val( : ) ) / SIZE( obj%val )
- !!
+ans = SUM(obj%val(1:obj%len)) / obj%len
END PROCEDURE fevar_Mean2
!----------------------------------------------------------------------------
@@ -90,43 +82,37 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Mean3
- REAL( DFP ), ALLOCATABLE :: val2( :, : ), val3( :, :, : )
- INTEGER( I4B ) :: ii, jj
- !!
- CALL Reallocate( ans, obj%s(1) )
- !!
- SELECT CASE( obj%varType )
- !!
- CASE( Constant )
- !!
- ans = obj%val( : )
- !!
- CASE( Space, Time )
- !!
- val2 = RESHAPE( obj%val, obj%s(1:2) )
- !!
- DO ii = 1, obj%s(2)
- ans = ans + val2( :, ii )
- END DO
- !!
- ans = ans / obj%s(2)
- !!
- CASE( SpaceTime )
- !!
- val3 = RESHAPE( obj%val, obj%s(1:3) )
- DO jj = 1, obj%s(3)
- DO ii = 1, obj%s(2)
- ans = ans + val3( :, ii, jj )
- END DO
- END DO
- !!
- ans = ans / obj%s(2) / obj%s(3)
- !!
- END SELECT
- !!
- IF( ALLOCATED( val2 ) ) DEALLOCATE( val2 )
- IF( ALLOCATED( val3 ) ) DEALLOCATE( val3 )
- !!
+INTEGER(I4B) :: ii, tsize
+
+tsize = obj%s(1)
+ALLOCATE (ans(tsize))
+
+SELECT CASE (obj%varType)
+
+CASE (Constant)
+
+ ans(1:tsize) = obj%val(1:tsize)
+
+CASE (Space, Time)
+
+ ans = 0.0
+ DO ii = 1, obj%s(2)
+ ans(1:tsize) = ans(1:tsize) + obj%val((ii - 1) * tsize + 1:ii * tsize)
+ END DO
+
+ ans(1:tsize) = ans(1:tsize) / obj%s(2)
+
+CASE (SpaceTime)
+
+ ans = 0.0
+ DO ii = 1, obj%s(2) * obj%s(3)
+ ans(1:tsize) = ans(1:tsize) + obj%val((ii - 1) * tsize + 1:ii * tsize)
+ END DO
+
+ ans(1:tsize) = ans(1:tsize) / (obj%s(2) * obj%s(3))
+
+END SELECT
+
END PROCEDURE fevar_Mean3
!----------------------------------------------------------------------------
@@ -134,44 +120,53 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Mean4
- REAL( DFP ), ALLOCATABLE :: val3( :, :, : ), val4( :, :, :, : )
- INTEGER( I4B ) :: ii, jj
- !!
- CALL Reallocate( ans, obj%s(1), obj%s(2) )
- !!
- SELECT CASE( obj%varType )
- !!
- CASE( Constant )
- !!
- ans = RESHAPE( obj%val, obj%s(1:2) )
- !!
- CASE( Space, Time )
- !!
- val3 = RESHAPE( obj%val, obj%s(1:3) )
- !!
- DO ii = 1, obj%s(3)
- ans = ans + val3( :, :, ii )
+INTEGER(I4B) :: ii, jj, kk, ll
+
+ALLOCATE (ans(obj%s(1), obj%s(2)))
+
+SELECT CASE (obj%varType)
+
+CASE (Constant)
+
+ DO CONCURRENT(ii=1:obj%s(1), jj=1:obj%s(2))
+ ans(ii, jj) = obj%val(Get1DIndexFortran(i=ii, j=jj, &
+ dim1=obj%s(1), dim2=obj%s(2)))
+ END DO
+
+CASE (Space, Time)
+
+ DO CONCURRENT(kk=1:obj%s(3))
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+
+ ans(ii, jj) = ans(ii, jj) &
+ + obj%val(Get1DIndexFortran(i=ii, j=jj, k=kk, &
+ dim1=obj%s(1), dim2=obj%s(2), dim3=obj%s(3)))
+
+ END DO
END DO
- !!
- ans = ans / obj%s(3)
- !!
- CASE( SpaceTime )
- !!
- val4 = RESHAPE( obj%val, obj%s(1:4) )
- !!
- DO jj = 1, obj%s(4)
- DO ii = 1, obj%s(3)
- ans = ans + val4( :, :, ii, jj )
+ END DO
+
+ ans = ans / obj%s(3)
+
+CASE (SpaceTime)
+
+ DO CONCURRENT(kk=1:obj%s(3), ll=1:obj%s(4))
+
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ ans(ii, jj) = ans(ii, jj) + obj%val(Get1DIndexFortran( &
+ i=ii, j=jj, k=kk, l=ll, &
+ dim1=obj%s(1), dim2=obj%s(2), dim3=obj%s(3), dim4=obj%s(4)))
+
END DO
END DO
- !!
- ans = ans / obj%s(3) / obj%s(4)
- !!
- END SELECT
- !!
- IF( ALLOCATED( val3 ) ) DEALLOCATE( val3 )
- IF( ALLOCATED( val4 ) ) DEALLOCATE( val4 )
- !!
+ END DO
+
+ ans = ans / (obj%s(3) * obj%s(4))
+
+END SELECT
+
END PROCEDURE fevar_Mean4
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90
index 2ce794012..2c72ac268 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90
@@ -14,11 +14,26 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
-#define _OP_ *
SUBMODULE(FEVariable_Method) MultiplicationMethods
-USE BaseMethod
+
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE ReallocateUtility, ONLY: Reallocate
+
+#define _OP_ *
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -26,62 +41,33 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Multiplication1
-!!
-REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:)
+REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :)
INTEGER(I4B) :: jj, kk
-!!
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
- !!
- select case( obj2%rank )
- !! scalar, scalar
- case( scalar )
-#include "./ScalarOperatorScalar.inc"
- !! scalar, vector
- case( vector )
-#include "./ScalarOperatorVector.inc"
- !! scalar, matrix
- case( matrix )
-#include "./ScalarOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (VECTOR)
- !!
- select case( obj2%rank )
- !! vector, scalar
- case( scalar )
-#include "./VectorOperatorScalar.inc"
- !! vector, vector
- case( vector )
-#include "./VectorOperatorVector.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (MATRIX)
- !!
- select case( obj2%rank )
- case( scalar )
- !! matrix, scalar
-#include "./MatrixOperatorScalar.inc"
- case( matrix )
- !! matrix, matrix
-#include "./MatrixOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
+CASE (scalar)
+ SELECT CASE (obj2%rank)
+ CASE (scalar)
+#include "./include/ScalarOperatorScalar.F90"
+ CASE (vector)
+#include "./include/ScalarOperatorVector.F90"
+ CASE (matrix)
+#include "./include/ScalarOperatorMatrix.F90"
+ END SELECT
+CASE (vector)
+ SELECT CASE (obj2%rank)
+ CASE (scalar)
+#include "./include/VectorOperatorScalar.F90"
+ CASE (vector)
+#include "./include/VectorOperatorVector.F90"
+ END SELECT
+CASE (matrix)
+ SELECT CASE (obj2%rank)
+ CASE (scalar)
+#include "./include/MatrixOperatorScalar.F90"
+ CASE (matrix)
+#include "./include/MatrixOperatorMatrix.F90"
+ END SELECT
END SELECT
-!!
END PROCEDURE fevar_Multiplication1
!----------------------------------------------------------------------------
@@ -90,30 +76,13 @@
MODULE PROCEDURE fevar_Multiplication2
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
-#include "./ScalarOperatorReal.inc"
-!!
-!!
-!!
-!!
-CASE (VECTOR)
-#include "./VectorOperatorReal.inc"
-!!
-!!
-!!
-!!
-CASE (MATRIX)
-#include "./MatrixOperatorReal.inc"
-!!
-!!
-!!
-!!
+CASE (scalar)
+#include "./include/ScalarOperatorReal.F90"
+CASE (vector)
+#include "./include/VectorOperatorReal.F90"
+CASE (matrix)
+#include "./include/MatrixOperatorReal.F90"
END SELECT
-!!
END PROCEDURE fevar_Multiplication2
!----------------------------------------------------------------------------
@@ -122,35 +91,18 @@
MODULE PROCEDURE fevar_Multiplication3
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
-#include "./RealOperatorScalar.inc"
-!!
-!!
-!!
-!!
-CASE (VECTOR)
-#include "./RealOperatorVector.inc"
-!!
-!!
-!!
-!!
-CASE (MATRIX)
-#include "./RealOperatorMatrix.inc"
-!!
-!!
-!!
-!!
+CASE (scalar)
+#include "./include/RealOperatorScalar.F90"
+CASE (vector)
+#include "./include/RealOperatorVector.F90"
+CASE (matrix)
+#include "./include/RealOperatorMatrix.F90"
END SELECT
-!!
END PROCEDURE fevar_Multiplication3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-END SUBMODULE MultiplicationMethods
#undef _OP_
+END SUBMODULE MultiplicationMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90
index 0306feadb..558a09ecd 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90
@@ -16,8 +16,24 @@
!
SUBMODULE(FEVariable_Method) Norm2Methods
-USE BaseMethod
+USE IntegerUtility, ONLY: Get1DIndexFortran
+
+USE GlobalData, ONLY: Scalar, Vector, Matrix, &
+ Constant, Space, Time, &
+ SpaceTime, Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE ReallocateUtility, ONLY: Reallocate
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -25,108 +41,79 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_norm2
-!! Internal variable
-REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:,:), r3(:, :, :), m3(:,:,:)
+REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:, :), r3(:, :, :), m3(:, :, :)
+
INTEGER(I4B) :: jj, kk
-!!
-!! main
-!!
+
SELECT CASE (obj%vartype)
-!!
-!!
-!!
-!!
+
CASE (constant)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & NORM2(obj%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(NORM2(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableConstant)
ELSE
- ans = QuadratureVariable( &
- & NORM2(obj%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
+ ans = QuadratureVariable(NORM2(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableConstant)
END IF
-!!
-!!
-!!
-!!
+
CASE (space)
- !!
+
r2 = GET(obj, TypeFEVariableVector, TypeFEVariableSpace)
- CALL Reallocate(r1, size(r2,2))
- DO jj = 1, size(r1)
- r1(jj) = NORM2(r2(:,jj))
+
+ CALL Reallocate(r1, SIZE(r2, 2))
+
+ DO jj = 1, SIZE(r1)
+ r1(jj) = NORM2(r2(:, jj))
END DO
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r1, &
+ typeFEVariableScalar, typeFEVariableSpace)
ELSE
- ans = QuadratureVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
+ ans = QuadratureVariable(r1, &
+ typeFEVariableScalar, typeFEVariableSpace)
END IF
-!!
-!!
-!!
-!!
+
CASE (time)
- !!
+
r2 = GET(obj, TypeFEVariableVector, TypeFEVariableTime)
- CALL Reallocate(r1, size(r2,2))
- DO jj = 1, size(r1)
- r1(jj) = NORM2(r2(:,jj))
+
+ CALL Reallocate(r1, SIZE(r2, 2))
+
+ DO jj = 1, SIZE(r1)
+ r1(jj) = NORM2(r2(:, jj))
END DO
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r1, &
+ typeFEVariableScalar, typeFEVariableTime)
ELSE
- ans = QuadratureVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
+ ans = QuadratureVariable(r1, &
+ typeFEVariableScalar, typeFEVariableTime)
END IF
-!!
-!!
-!!
-!!
+
CASE (spacetime)
- !!
+
r3 = GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime)
- CALL Reallocate( r2, size(r3,2), size(r3,3) )
- !!
+
+ CALL Reallocate(r2, SIZE(r3, 2), SIZE(r3, 3))
+
DO kk = 1, SIZE(r3, 3)
DO jj = 1, SIZE(r3, 2)
r2(jj, kk) = NORM2(r3(:, jj, kk))
END DO
END DO
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r2, &
+ typeFEVariableScalar, typeFEVariableSpaceTime)
ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
+ ans = QuadratureVariable(r2, &
+ typeFEVariableScalar, typeFEVariableSpaceTime)
END IF
- !!
+
END SELECT
-!!
-!!
-!!
-!!
END PROCEDURE fevar_norm2
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90
index e8eff5ef2..800f72949 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90
@@ -16,7 +16,17 @@
!
SUBMODULE(FEVariable_Method) PowerMethods
-USE BaseMethod
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
IMPLICIT NONE
CONTAINS
@@ -26,18 +36,13 @@
MODULE PROCEDURE fevar_power
SELECT CASE (obj%rank)
-!!
-CASE (SCALAR)
-#include "./ScalarPower.inc"
-!!
-CASE (VECTOR)
-#include "./VectorPower.inc"
-!!
-CASE (MATRIX)
-#include "./MatrixPower.inc"
-!!
+CASE (scalar)
+#include "./include/ScalarPower.F90"
+CASE (vector)
+#include "./include/VectorPower.F90"
+CASE (matrix)
+#include "./include/MatrixPower.F90"
END SELECT
-!!
END PROCEDURE fevar_power
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90
index b0fac6f68..6dbcbef79 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90
@@ -18,7 +18,17 @@
#define _ELEM_METHOD_ SQRT
SUBMODULE(FEVariable_Method) SqrtMethods
-USE BaseMethod
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
IMPLICIT NONE
CONTAINS
@@ -28,18 +38,13 @@
MODULE PROCEDURE fevar_sqrt
SELECT CASE (obj%rank)
-!!
-CASE (SCALAR)
-#include "./ScalarElemMethod.inc"
-!!
-CASE (VECTOR)
-#include "./VectorElemMethod.inc"
-!!
-CASE (MATRIX)
-#include "./MatrixElemMethod.inc"
-!!
+CASE (scalar)
+#include "./include/ScalarElemMethod.F90"
+CASE (vector)
+#include "./include/VectorElemMethod.F90"
+CASE (matrix)
+#include "./include/MatrixElemMethod.F90"
END SELECT
-!!
END PROCEDURE fevar_sqrt
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90
index 7ce5b3cef..ab1f27b03 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90
@@ -14,10 +14,24 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
-#define _OP_ -
SUBMODULE(FEVariable_Method) SubtractionMethods
-USE BaseMethod
+
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE ReallocateUtility, ONLY: Reallocate
+
+#define _OP_ -
+
IMPLICIT NONE
CONTAINS
@@ -26,62 +40,54 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Subtraction1
-!!
-REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:,:,:,:), m2(:,:)
+REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :), m2(:, :)
INTEGER(I4B) :: jj, kk
-!!
+
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
-CASE (SCALAR)
- !!
- select case( obj2%rank )
- !! scalar, scalar
- case( scalar )
-#include "./ScalarOperatorScalar.inc"
- !! scalar, vector
- case( vector )
-#include "./ScalarOperatorVector.inc"
- !! scalar, matrix
- case( matrix )
-#include "./ScalarOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (VECTOR)
- !!
- select case( obj2%rank )
- !! vector, scalar
- case( scalar )
-#include "./VectorOperatorScalar.inc"
- !! vector, vector
- case( vector )
-#include "./VectorOperatorVector.inc"
- end select
-!!
-!!
-!!
-!!
-CASE (MATRIX)
- !!
- select case( obj2%rank )
- case( scalar )
- !! matrix, scalar
-#include "./MatrixOperatorScalar.inc"
- case( matrix )
- !! matrix, matrix
-#include "./MatrixOperatorMatrix.inc"
- end select
-!!
-!!
-!!
-!!
+
+CASE (scalar)
+
+ SELECT CASE (obj2%rank)
+
+ CASE (scalar)
+
+#include "./include/ScalarOperatorScalar.F90"
+
+ CASE (vector)
+
+#include "./include/ScalarOperatorVector.F90"
+
+ CASE (matrix)
+
+#include "./include/ScalarOperatorMatrix.F90"
+ END SELECT
+
+CASE (vector)
+
+ SELECT CASE (obj2%rank)
+
+ CASE (scalar)
+
+#include "./include/VectorOperatorScalar.F90"
+
+ CASE (vector)
+
+#include "./include/VectorOperatorVector.F90"
+ END SELECT
+
+CASE (matrix)
+
+ SELECT CASE (obj2%rank)
+
+ CASE (scalar)
+
+#include "./include/MatrixOperatorScalar.F90"
+
+ CASE (matrix)
+
+#include "./include/MatrixOperatorMatrix.F90"
+ END SELECT
END SELECT
-!!
END PROCEDURE fevar_Subtraction1
!----------------------------------------------------------------------------
@@ -89,31 +95,21 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Subtraction2
+
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
+
CASE (SCALAR)
-#include "./ScalarOperatorReal.inc"
-!!
-!!
-!!
-!!
+
+#include "./include/ScalarOperatorReal.F90"
+
CASE (VECTOR)
-#include "./VectorOperatorReal.inc"
-!!
-!!
-!!
-!!
+
+#include "./include/VectorOperatorReal.F90"
+
CASE (MATRIX)
-#include "./MatrixOperatorReal.inc"
-!!
-!!
-!!
-!!
+
+#include "./include/MatrixOperatorReal.F90"
END SELECT
-!!
END PROCEDURE fevar_Subtraction2
!----------------------------------------------------------------------------
@@ -121,31 +117,21 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE fevar_Subtraction3
+
SELECT CASE (obj1%rank)
-!!
-!!
-!!
-!!
+
CASE (SCALAR)
-#include "./RealOperatorScalar.inc"
-!!
-!!
-!!
-!!
+
+#include "./include/RealOperatorScalar.F90"
+
CASE (VECTOR)
-#include "./RealOperatorVector.inc"
-!!
-!!
-!!
-!!
+
+#include "./include/RealOperatorVector.F90"
+
CASE (MATRIX)
-#include "./RealOperatorMatrix.inc"
-!!
-!!
-!!
-!!
+
+#include "./include/RealOperatorMatrix.F90"
END SELECT
-!!
END PROCEDURE fevar_Subtraction3
!----------------------------------------------------------------------------
diff --git a/src/submodules/FEVariable/src/MatrixElemMethod.inc b/src/submodules/FEVariable/src/MatrixElemMethod.inc
deleted file mode 100644
index b308a1b36..000000000
--- a/src/submodules/FEVariable/src/MatrixElemMethod.inc
+++ /dev/null
@@ -1,92 +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
-!
-!!
-!! main
-!!
-SELECT CASE (obj%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/MatrixOperatorMatrix.inc b/src/submodules/FEVariable/src/MatrixOperatorMatrix.inc
deleted file mode 100644
index 5704e3445..000000000
--- a/src/submodules/FEVariable/src/MatrixOperatorMatrix.inc
+++ /dev/null
@@ -1,265 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! Internal variable
-!!
-! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :)
-! INTEGER(I4B) :: jj, kk
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant + constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
- r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace)
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj)
- END DO
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
- r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime)
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj)
- END DO
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
- r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
- DO kk = 1, SIZE(r4, 4)
- DO jj = 1, SIZE(r4, 3)
- r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk)
- END DO
- END DO
- !!
- IF(obj2%defineon .EQ. nodal) THEN
- ans = NodalVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace)
- r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant)
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :)
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime)
- r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant)
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :)
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
- r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant)
- DO kk = 1, SIZE(r4, 4)
- DO jj = 1, SIZE(r4, 3)
- r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :)
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- END SELECT
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/MatrixOperatorReal.inc b/src/submodules/FEVariable/src/MatrixOperatorReal.inc
deleted file mode 100644
index f90524bee..000000000
--- a/src/submodules/FEVariable/src/MatrixOperatorReal.inc
+++ /dev/null
@@ -1,92 +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
-!
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/MatrixOperatorScalar.inc b/src/submodules/FEVariable/src/MatrixOperatorScalar.inc
deleted file mode 100644
index 0c4ac6645..000000000
--- a/src/submodules/FEVariable/src/MatrixOperatorScalar.inc
+++ /dev/null
@@ -1,271 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant)
- CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1))
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r2 _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj2%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- r2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant)
- !!
- CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj2%s(1))
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r2 _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj2%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime)
- m2 = GET(obj1, typeFEVariableMatrix, typeFEVariableConstant)
- !!
- CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) )
- !!
- DO kk = 1, SIZE(r4, 4)
- DO jj = 1, SIZE(r4, 3)
- r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk)
- END DO
- END DO
- !!
- IF(obj2%defineon .EQ. Nodal) THEN
- ans = NodalVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
-!!
- SELECT CASE (obj1%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace)
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj1%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime)
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj1%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r4 = GET(obj1, typeFEVariableMatrix, typeFEVariableSpaceTime)
- r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime)
- !!
- DO kk = 1, SIZE(r4, 4)
- DO jj = 1, SIZE(r4, 3)
- r4(:, :, jj, kk) = r4(:,:,jj,kk) _OP_ r2(jj, kk)
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/RealOperatorMatrix.inc b/src/submodules/FEVariable/src/RealOperatorMatrix.inc
deleted file mode 100644
index 4e5fd0910..000000000
--- a/src/submodules/FEVariable/src/RealOperatorMatrix.inc
+++ /dev/null
@@ -1,93 +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
-!
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/RealOperatorScalar.inc b/src/submodules/FEVariable/src/RealOperatorScalar.inc
deleted file mode 100644
index 65efe4e82..000000000
--- a/src/submodules/FEVariable/src/RealOperatorScalar.inc
+++ /dev/null
@@ -1,97 +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
-!
-!
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & val _OP_ obj1%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & val _OP_ obj1%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & val _OP_ obj1%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & val _OP_ obj1%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & val _OP_ obj1%val(:) , &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & val _OP_ obj1%val(:) , &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/RealOperatorVector.inc b/src/submodules/FEVariable/src/RealOperatorVector.inc
deleted file mode 100644
index c3967937d..000000000
--- a/src/submodules/FEVariable/src/RealOperatorVector.inc
+++ /dev/null
@@ -1,93 +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
-!
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & val _OP_ obj1%val(:), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & val _OP_ obj1%val(:), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(val _OP_ obj1%val(:), obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/ScalarElemMethod.inc b/src/submodules/FEVariable/src/ScalarElemMethod.inc
deleted file mode 100644
index 3d6619764..000000000
--- a/src/submodules/FEVariable/src/ScalarElemMethod.inc
+++ /dev/null
@@ -1,94 +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
-!
-!
-!!
-!! main
-!!
-SELECT CASE (obj%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & _ELEM_METHOD_(obj%val(1)), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & _ELEM_METHOD_(obj%val(1)), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & _ELEM_METHOD_(obj%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & _ELEM_METHOD_(obj%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & _ELEM_METHOD_(obj%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & _ELEM_METHOD_(obj%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/ScalarOperatorMatrix.inc b/src/submodules/FEVariable/src/ScalarOperatorMatrix.inc
deleted file mode 100644
index 94ae9d056..000000000
--- a/src/submodules/FEVariable/src/ScalarOperatorMatrix.inc
+++ /dev/null
@@ -1,270 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableMatrix, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:4)), &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant)
- CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1))
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = obj1%val(jj) _OP_ r2
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace)
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpace)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant)
- !!
- CALL Reallocate(r3, SIZE(r2,1), SIZE(r2,2), obj1%s(1))
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = obj1%val(jj) _OP_ r2
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime)
- !!
- DO jj = 1, SIZE(r3, 3)
- r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableMatrix, &
- & typeFEVariableTime)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
- m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant)
- !!
- CALL Reallocate( r4, SIZE(m2, 1), SIZE(m2,2), SIZE(r2,1), SIZE(r2,2) )
- !!
- DO kk = 1, SIZE(r4, 4)
- DO jj = 1, SIZE(r4, 3)
- r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2
- END DO
- END DO
- !!
- IF(obj1%defineon .EQ. Nodal) THEN
- ans = NodalVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
- r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime)
- !!
- DO kk = 1, SIZE(r4, 4)
- DO jj = 1, SIZE(r4, 3)
- r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:,:,jj,kk)
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r4, &
- & typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/ScalarOperatorReal.inc b/src/submodules/FEVariable/src/ScalarOperatorReal.inc
deleted file mode 100644
index d0052e005..000000000
--- a/src/submodules/FEVariable/src/ScalarOperatorReal.inc
+++ /dev/null
@@ -1,97 +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
-!
-!
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(1) _OP_ val, &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(1) _OP_ val, &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & obj1%val(:) _OP_ val, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & obj1%val(:) _OP_ val, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(:) _OP_ val, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(:) _OP_ val, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/ScalarOperatorScalar.inc b/src/submodules/FEVariable/src/ScalarOperatorScalar.inc
deleted file mode 100644
index 57cf08dd1..000000000
--- a/src/submodules/FEVariable/src/ScalarOperatorScalar.inc
+++ /dev/null
@@ -1,223 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant + constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(1) _OP_ obj2%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(1) _OP_ obj2%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- IF( obj2%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & obj1%val(1) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & obj1%val(1) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- IF( obj2%defineon .EQ. Nodal) THEN
- ans = NodalVariable(&
- & obj1%val(1) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & obj1%val(1) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- IF( obj2%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & obj1%val(:) _OP_ obj2%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & obj1%val(:) _OP_ obj2%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(:) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(:) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(:) _OP_ obj2%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(:) _OP_ obj2%val(1), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & obj1%val(:) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & obj1%val(:) _OP_ obj2%val(:), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- IF(obj1%defineon .EQ. Nodal) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/ScalarOperatorVector.inc b/src/submodules/FEVariable/src/ScalarOperatorVector.inc
deleted file mode 100644
index 8721caf43..000000000
--- a/src/submodules/FEVariable/src/ScalarOperatorVector.inc
+++ /dev/null
@@ -1,265 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(1) _OP_ obj2%val(:), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(1) _OP_ obj2%val(:), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(1) _OP_ obj2%val(:), obj2%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- CALL Reallocate(r2, obj2%s(1), obj1%s(1) )
- !!
- DO jj = 1, size(r2, 2)
- r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
- !!
- DO jj = 1, size(r2, 2)
- r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- CALL Reallocate(r2, obj2%s(1), obj1%s(1) )
- !!
- DO jj = 1, size(r2, 2)
- r2(:, jj) = obj1%val(jj) _OP_ obj2%val(:)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
- !!
- DO jj = 1, size(r2, 2)
- r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
- CALL Reallocate( r3, obj2%s(1), size(r2,1), size(r2,2) )
- !!
- DO kk = 1, size(r3, 3)
- DO jj = 1, size(r3, 2)
- r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(:)
- END DO
- END DO
- !!
- IF(obj1%defineon .EQ. Nodal) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
- r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime)
- !!
- DO kk = 1, size(r3, 3)
- DO jj = 1, size(r3, 2)
- r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:,jj,kk)
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/ScalarPower.inc b/src/submodules/FEVariable/src/ScalarPower.inc
deleted file mode 100644
index 2d2f8c032..000000000
--- a/src/submodules/FEVariable/src/ScalarPower.inc
+++ /dev/null
@@ -1,94 +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
-!
-!
-!!
-!! main
-!!
-SELECT CASE (obj%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & obj%val(1) ** n, &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj%val(1) ** n, &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- END IF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & obj%val(:) ** n, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & obj%val(:) ** n, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & obj%val(:) ** n, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & obj%val(:) ** n, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj%val(:) ** n, obj%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj%val(:) ** n, obj%s(1:2)), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/VectorElemMethod.inc b/src/submodules/FEVariable/src/VectorElemMethod.inc
deleted file mode 100644
index c36a5c454..000000000
--- a/src/submodules/FEVariable/src/VectorElemMethod.inc
+++ /dev/null
@@ -1,93 +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
-!
-!!
-!! main
-!!
-SELECT CASE (obj%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & _ELEM_METHOD_(obj%val(:)), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & _ELEM_METHOD_(obj%val(:)), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ENDIF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ENDIF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ENDIF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(_ELEM_METHOD_(obj%val(:)), obj%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ENDIF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/VectorOperatorReal.inc b/src/submodules/FEVariable/src/VectorOperatorReal.inc
deleted file mode 100644
index 439c71976..000000000
--- a/src/submodules/FEVariable/src/VectorOperatorReal.inc
+++ /dev/null
@@ -1,97 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(:) _OP_ val, &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(:) _OP_ val, &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ENDIF
-!!
-!!
-!!
-!!
-CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ENDIF
-!!
-!!
-!!
-!!
-CASE (time)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ENDIF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ val, obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ENDIF
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/VectorOperatorScalar.inc b/src/submodules/FEVariable/src/VectorOperatorScalar.inc
deleted file mode 100644
index 1f44747c1..000000000
--- a/src/submodules/FEVariable/src/VectorOperatorScalar.inc
+++ /dev/null
@@ -1,265 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(:) _OP_ obj2%val(1), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(:) _OP_ obj2%val(1), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- CALL Reallocate(r2, obj1%s(1), obj2%s(1))
- !!
- DO jj = 1, SIZE(r2, 2)
- r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj2%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- CALL Reallocate(r2, obj1%s(1), obj2%s(1))
- !!
- DO jj = 1, SIZE(r2, 2)
- r2(:, jj) = obj1%val(:) _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj2%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime)
- CALL Reallocate( r3, obj1%s(1), SIZE(r2,1), SIZE(r2,2) )
- !!
- DO kk = 1, SIZE(r3, 3)
- DO jj = 1, SIZE(r3, 2)
- r3(:, jj, kk) = obj1%val(:) _OP_ r2(jj, kk)
- END DO
- END DO
- !!
- IF(obj2%defineon .EQ. Nodal) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
-!!
- SELECT CASE (obj1%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
- !!
- DO jj = 1, SIZE(r2, 2)
- r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj1%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
- !!
- DO jj = 1, SIZE(r2, 2)
- r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj)
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- END SELECT
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj1%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(1), obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime)
- r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime)
- !!
- DO kk = 1, SIZE(r3, 3)
- DO jj = 1, SIZE(r3, 2)
- r3(:, jj, kk) = r3(:,jj,kk) _OP_ r2(jj, kk)
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. Nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-END SELECT
diff --git a/src/submodules/FEVariable/src/VectorOperatorVector.inc b/src/submodules/FEVariable/src/VectorOperatorVector.inc
deleted file mode 100644
index a8a1d632f..000000000
--- a/src/submodules/FEVariable/src/VectorOperatorVector.inc
+++ /dev/null
@@ -1,258 +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
-!
-
-!----------------------------------------------------------------------------
-! ScalarAddition
-!----------------------------------------------------------------------------
-
-!! Internal variable
-! REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :)
-! INTEGER(I4B) :: jj, kk
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant _OP_ constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & obj1%val(:) _OP_ obj2%val(:), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & obj1%val(:) _OP_ obj2%val(:), &
- & typeFEVariableVector, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant _OP_ space
- !!
- CASE (space)
- !!
- r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
- DO jj = 1, SIZE(r2, 2)
- r2(:, jj) = obj1%val(:) _OP_ r2(:, jj)
- END DO
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant _OP_ time
- !!
- CASE (time)
- !!
- r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
- DO jj = 1, SIZE(r2, 2)
- r2(:, jj) = obj1%val(:) _OP_ r2(:, jj)
- END DO
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime)
- DO kk = 1, SIZE(r3, 3)
- DO jj = 1, SIZE(r3, 2)
- r3(:, jj, kk) = obj1%val(:) _OP_ r3(:, jj, kk)
- END DO
- END DO
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! space=space _OP_ constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
- !!
- DO jj = 1, SIZE(r2,2)
- r2(:, jj) = r2(:, jj) _OP_ obj2%val(:)
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space _OP_ space
- !!
- CASE (space)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableSpace)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! time=time _OP_ constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
- DO jj = 1, SIZE(r2,2)
- r2(:, jj) = r2(:, jj) _OP_ obj2%val(:)
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & r2, &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time _OP_ time
- !!
- CASE (time)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:2)), &
- & typeFEVariableVector, &
- & typeFEVariableTime)
- END IF
- !!
- END SELECT
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! spacetime= spacetime _OP_ constant
- !!
- CASE (constant)
- !!
- r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime)
- DO kk = 1, SIZE(r3, 3)
- DO jj = 1, SIZE(r3, 2)
- r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(:)
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r3, &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime _OP_ spacetime
- !!
- CASE (spacetime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & RESHAPE(obj1%val(:) _OP_ obj2%val(:), obj1%s(1:3)), &
- & typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
- !!
-END SELECT
diff --git a/src/submodules/FEVariable/src/include/MatrixElemMethod.F90 b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90
new file mode 100644
index 000000000..0f4640043
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/MatrixElemMethod.F90
@@ -0,0 +1,50 @@
+! 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
+
+SELECT CASE (obj%vartype)
+CASE (constant)
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2))
+ ELSE
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableConstant, obj%s(1:2))
+ END IF
+CASE (space)
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3))
+ ELSE
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableSpace, obj%s(1:3))
+ END IF
+CASE (time)
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3))
+ ELSE
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableTime, obj%s(1:3))
+ END IF
+CASE (spacetime)
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4))
+ ELSE
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableMatrix, typeFEVariableSpaceTime, obj%s(1:4))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90
new file mode 100644
index 000000000..49ec28c4d
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/MatrixOperatorMatrix.F90
@@ -0,0 +1,129 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2))
+ END IF
+ CASE (space)
+ r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
+ r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj)
+ END DO
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace)
+ END IF
+ DEALLOCATE (r2, r3)
+ CASE (time)
+ r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
+ r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r2(:, :) _OP_ r3(:, :, jj)
+ END DO
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime)
+ END IF
+ DEALLOCATE (r2, r3)
+ CASE (spacetime)
+ r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
+ r4 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ DO kk = 1, SIZE(r4, 4)
+ DO jj = 1, SIZE(r4, 3)
+ r4(:, :, jj, kk) = r2(:, :) _OP_ r4(:, :, jj, kk)
+ END DO
+ END DO
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r4, TypeFEVariableMatrix, &
+ TypeFEVariableSpaceTime)
+ END IF
+ DEALLOCATE (r2, r4)
+ END SELECT
+CASE (space)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace)
+ r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :)
+ END DO
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r3, &
+ TypeFEVariableMatrix, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r3, &
+ TypeFEVariableMatrix, TypeFEVariableSpace)
+ END IF
+ DEALLOCATE (r2, r3)
+ CASE (space)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3))
+ END IF
+ END SELECT
+CASE (time)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime)
+ r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r3(:, :, jj) _OP_ r2(:, :)
+ END DO
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r3, &
+ TypeFEVariableMatrix, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r3, &
+ TypeFEVariableMatrix, TypeFEVariableTime)
+ END IF
+ DEALLOCATE (r2, r3)
+ CASE (time)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3))
+ END IF
+ END SELECT
+CASE (spacetime)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ r2 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableConstant)
+ DO kk = 1, SIZE(r4, 4)
+ DO jj = 1, SIZE(r4, 3)
+ r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(:, :)
+ END DO
+ END DO
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r4, &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r4, &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ END IF
+ DEALLOCATE (r2, r4)
+ CASE (spacetime)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4))
+ END IF
+ END SELECT
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90
new file mode 100644
index 000000000..74cb5c110
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/MatrixOperatorReal.F90
@@ -0,0 +1,34 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2))
+ END IF
+CASE (space)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3))
+ END IF
+CASE (time)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3))
+ END IF
+CASE (spacetime)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90 b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90
new file mode 100644
index 000000000..3b66f3643
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/MatrixOperatorScalar.F90
@@ -0,0 +1,164 @@
+SELECT CASE (obj1%varType)
+
+CASE (constant)
+
+ SELECT CASE (obj2%varType)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableConstant, obj1%s(1:2))
+ END IF
+
+ CASE (space)
+
+ r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
+ CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1))
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r2 _OP_ obj2%val(jj)
+ END DO
+
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace)
+ END IF
+
+ DEALLOCATE (r2, r3)
+ CASE (time)
+
+ r2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
+ CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj2%s(1))
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r2 _OP_ obj2%val(jj)
+ END DO
+
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime)
+ END IF
+
+ DEALLOCATE (r2, r3)
+ CASE (spacetime)
+
+ r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime)
+ m2 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableConstant)
+ CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2))
+ DO kk = 1, SIZE(r4, 4)
+ DO jj = 1, SIZE(r4, 3)
+ r4(:, :, jj, kk) = m2 _OP_ r2(jj, kk)
+ END DO
+
+ END DO
+
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r4, TypeFEVariableMatrix, &
+ TypeFEVariableSpaceTime)
+ END IF
+
+ DEALLOCATE (r2, r4, m2)
+ END SELECT
+
+CASE (space)
+
+ SELECT CASE (obj1%varType)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableSpace, obj1%s(1:3))
+ END IF
+
+ CASE (space)
+
+ r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpace)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableSpace)
+ END IF
+
+ DEALLOCATE (r3)
+ END SELECT
+
+CASE (time)
+
+ SELECT CASE (obj1%varType)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableTime, obj1%s(1:3))
+ END IF
+
+ CASE (time)
+
+ r3 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableTime)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = r3(:, :, jj) _OP_ obj2%val(jj)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r3, TypeFEVariableMatrix, TypeFEVariableTime)
+ END IF
+
+ DEALLOCATE (r3)
+ END SELECT
+
+CASE (spacetime)
+
+ SELECT CASE (obj1%varType)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableMatrix, TypeFEVariableSpaceTime, obj1%s(1:4))
+ END IF
+
+ CASE (spacetime)
+
+ r4 = GET(obj1, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ r2 = GET(obj2, TypeFEVariableScalar, TypeFEVariableSpaceTime)
+ DO kk = 1, SIZE(r4, 4)
+ DO jj = 1, SIZE(r4, 3)
+ r4(:, :, jj, kk) = r4(:, :, jj, kk) _OP_ r2(jj, kk)
+ END DO
+
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r4, TypeFEVariableMatrix, TypeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r4, TypeFEVariableMatrix, &
+ TypeFEVariableSpaceTime)
+ END IF
+
+ DEALLOCATE (r2, r4)
+ END SELECT
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/MatrixPower.inc b/src/submodules/FEVariable/src/include/MatrixPower.F90
similarity index 100%
rename from src/submodules/FEVariable/src/MatrixPower.inc
rename to src/submodules/FEVariable/src/include/MatrixPower.F90
diff --git a/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90
new file mode 100644
index 000000000..9295afd5d
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/RealOperatorMatrix.F90
@@ -0,0 +1,34 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableConstant, obj1%s(1:2))
+ END IF
+CASE (space)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableSpace, obj1%s(1:3))
+ END IF
+CASE (time)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableTime, obj1%s(1:3))
+ END IF
+CASE (spacetime)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4))
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ typeFEVariableMatrix, typeFEVariableSpaceTime, obj1%s(1:4))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/RealOperatorScalar.F90 b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90
new file mode 100644
index 000000000..6e0fbc67c
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/RealOperatorScalar.F90
@@ -0,0 +1,34 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1), &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1), &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ END IF
+CASE (space)
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+ END IF
+CASE (time)
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ END IF
+CASE (spacetime)
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/RealOperatorVector.F90 b/src/submodules/FEVariable/src/include/RealOperatorVector.F90
new file mode 100644
index 000000000..69afa2912
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/RealOperatorVector.F90
@@ -0,0 +1,43 @@
+SELECT CASE (obj1%vartype)
+
+CASE (constant)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableVector, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableVector, TypeFEVariableConstant)
+ END IF
+
+CASE (space)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(val _OP_ obj1%val(1:obj1%len), &
+ TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), &
+ TypeFEVariableVector, TypeFEVariableSpace)
+ END IF
+
+CASE (time)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), &
+ TypeFEVariableVector, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:2)), &
+ TypeFEVariableVector, TypeFEVariableTime)
+ END IF
+
+CASE (spacetime)
+
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), &
+ TypeFEVariableVector, TypeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(RESHAPE(val _OP_ obj1%val(1:obj1%len), obj1%s(1:3)), &
+ TypeFEVariableVector, TypeFEVariableSpaceTime)
+ END IF
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/ScalarElemMethod.F90 b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90
new file mode 100644
index 000000000..47f10e592
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/ScalarElemMethod.F90
@@ -0,0 +1,61 @@
+! 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
+!
+!
+SELECT CASE (obj%vartype)
+CASE (constant)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, &
+ typeFEVariableConstant)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1)), typeFEVariableScalar, &
+ typeFEVariableConstant)
+CASE (space)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableSpace)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableSpace)
+
+CASE (time)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableTime)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableTime)
+
+CASE (spacetime)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableSpaceTime, obj%s(1:2))
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90
new file mode 100644
index 000000000..3692e97ec
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/ScalarOperatorMatrix.F90
@@ -0,0 +1,186 @@
+SELECT CASE (obj1%vartype)
+
+CASE (constant)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2))
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableConstant, obj2%s(1:2))
+
+ CASE (space)
+
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableSpace, obj2%s(1:3))
+
+ CASE (time)
+
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableTime, obj2%s(1:3))
+
+ CASE (spacetime)
+
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableMatrix, typeFEVariableSpaceTime, obj2%s(1:4))
+
+ END SELECT
+
+CASE (space)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant)
+ CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1))
+
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = obj1%val(jj) _OP_ r2
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace)
+ DEALLOCATE (r2, r3)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace)
+ DEALLOCATE (r2, r3)
+
+ CASE (space)
+
+ r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableSpace)
+
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableSpace)
+ DEALLOCATE (r3)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableSpace)
+ DEALLOCATE (r3)
+
+ END SELECT
+
+CASE (time)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ r2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant)
+ CALL Reallocate(r3, SIZE(r2, 1), SIZE(r2, 2), obj1%s(1))
+
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = obj1%val(jj) _OP_ r2
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime)
+ DEALLOCATE (r2, r3)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime)
+ DEALLOCATE (r2, r3)
+
+ CASE (time)
+
+ r3 = GET(obj2, TypeFEVariableMatrix, TypeFEVariableTime)
+ DO jj = 1, SIZE(r3, 3)
+ r3(:, :, jj) = obj1%val(jj) _OP_ r3(:, :, jj)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableMatrix, typeFEVariableTime)
+ DEALLOCATE (r3)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r3, typeFEVariableMatrix, typeFEVariableTime)
+ DEALLOCATE (r3)
+
+ END SELECT
+
+CASE (spacetime)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
+ m2 = GET(obj2, typeFEVariableMatrix, typeFEVariableConstant)
+ CALL Reallocate(r4, SIZE(m2, 1), SIZE(m2, 2), SIZE(r2, 1), SIZE(r2, 2))
+
+ DO kk = 1, SIZE(r4, 4)
+ DO jj = 1, SIZE(r4, 3)
+ r4(:, :, jj, kk) = r2(jj, kk) _OP_ m2
+ END DO
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r4, typeFEVariableMatrix, typeFEVariableSpaceTime)
+ DEALLOCATE (r2, m2, r4)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r4, typeFEVariableMatrix, &
+ typeFEVariableSpaceTime)
+
+ DEALLOCATE (r2, m2, r4)
+
+ CASE (spacetime)
+
+ r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
+ r4 = GET(obj2, typeFEVariableMatrix, typeFEVariableSpaceTime)
+
+ DO kk = 1, SIZE(r4, 4)
+ DO jj = 1, SIZE(r4, 3)
+ r4(:, :, jj, kk) = r2(jj, kk) _OP_ r4(:, :, jj, kk)
+ END DO
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r4, typeFEVariableMatrix, &
+ typeFEVariableSpaceTime)
+ DEALLOCATE (r2, r4)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r4, typeFEVariableMatrix, &
+ typeFEVariableSpaceTime)
+ DEALLOCATE (r2, r4)
+
+ END SELECT
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90
new file mode 100644
index 000000000..fa3e91c56
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/ScalarOperatorReal.F90
@@ -0,0 +1,34 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(obj1%val(1) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ END IF
+CASE (space)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+ END IF
+CASE (time)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ END IF
+CASE (spacetime)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90
new file mode 100644
index 000000000..8e121f01d
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/ScalarOperatorScalar.F90
@@ -0,0 +1,148 @@
+SELECT CASE (obj1%vartype)
+
+CASE (constant)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+
+ RETURN
+
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+
+ CASE (space)
+
+ IF (obj2%defineon .EQ. Nodal) THEN
+
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+
+ CASE (time)
+
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+
+ CASE (spacetime)
+
+ IF (obj2%defineon .EQ. Nodal) THEN
+
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2))
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj2%s(1:2))
+
+ END SELECT
+
+CASE (space)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+
+ CASE (space)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+
+ END SELECT
+
+CASE (time)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+
+ CASE (time)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ RETURN
+ END IF
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableTime)
+
+ END SELECT
+
+CASE (spacetime)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+ RETURN
+ END IF
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+
+ CASE (spacetime)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+ RETURN
+ END IF
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj1%s(1:2))
+
+ END SELECT
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90 b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90
new file mode 100644
index 000000000..594629b64
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/ScalarOperatorVector.F90
@@ -0,0 +1,180 @@
+SELECT CASE (obj1%vartype)
+
+CASE (constant)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableConstant)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableConstant)
+ CASE (space)
+
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2))
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpace, obj2%s(1:2))
+ CASE (time)
+
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableTime, obj2%s(1:2))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableTime, obj2%s(1:2))
+
+ CASE (spacetime)
+
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(obj1%val(1) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj2%s(1:3))
+
+ END SELECT
+
+CASE (space)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ CALL Reallocate(r2, obj2%s(1), obj1%s(1))
+
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+
+ CASE (space)
+
+ r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
+
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ DEALLOCATE (r2)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ DEALLOCATE (r2)
+
+ END SELECT
+
+CASE (time)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ CALL Reallocate(r2, obj2%s(1), obj1%s(1))
+
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(jj) _OP_ obj2%val(1:obj2%len)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ DEALLOCATE (r2)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ DEALLOCATE (r2)
+
+ CASE (time)
+
+ r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
+
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(jj) _OP_ r2(:, jj)
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ DEALLOCATE (r2)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ DEALLOCATE (r2)
+
+ END SELECT
+
+CASE (spacetime)
+
+ SELECT CASE (obj2%vartype)
+
+ CASE (constant)
+
+ r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
+ CALL Reallocate(r3, obj2%s(1), SIZE(r2, 1), SIZE(r2, 2))
+
+ DO kk = 1, SIZE(r3, 3)
+ DO jj = 1, SIZE(r3, 2)
+ r3(:, jj, kk) = r2(jj, kk) _OP_ obj2%val(1:obj2%len)
+ END DO
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime)
+ DEALLOCATE (r2, r3)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r3, typeFEVariableVector, &
+ typeFEVariableSpaceTime)
+
+ DEALLOCATE (r2, r3)
+
+ CASE (spacetime)
+ r2 = GET(obj1, typeFEVariableScalar, typeFEVariableSpaceTime)
+ r3 = GET(obj2, typeFEVariableVector, typeFEVariableSpaceTime)
+
+ DO kk = 1, SIZE(r3, 3)
+ DO jj = 1, SIZE(r3, 2)
+ r3(:, jj, kk) = r2(jj, kk) _OP_ r3(:, jj, kk)
+ END DO
+ END DO
+
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime)
+ DEALLOCATE (r2, r3)
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(r3, typeFEVariableVector, &
+ typeFEVariableSpaceTime)
+
+ DEALLOCATE (r2, r3)
+
+ END SELECT
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/ScalarPower.F90 b/src/submodules/FEVariable/src/include/ScalarPower.F90
new file mode 100644
index 000000000..48f45c3dc
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/ScalarPower.F90
@@ -0,0 +1,42 @@
+SELECT CASE (obj%vartype)
+
+CASE (constant)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj%val(1)**n, &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(obj%val(1)**n, &
+ TypeFEVariableScalar, TypeFEVariableConstant)
+ END IF
+
+CASE (space)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj%val(1:obj%len)**n, &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(obj%val(1:obj%len)**n, &
+ TypeFEVariableScalar, TypeFEVariableSpace)
+ END IF
+
+CASE (time)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj%val(1:obj%len)**n, &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(obj%val(1:obj%len)**n, &
+ TypeFEVariableScalar, TypeFEVariableTime)
+ END IF
+
+CASE (spacetime)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj%val(1:obj%len)**n, &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj%val(1:obj%len)**n, &
+ TypeFEVariableScalar, TypeFEVariableSpaceTime, obj%s(1:2))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/VectorElemMethod.F90 b/src/submodules/FEVariable/src/include/VectorElemMethod.F90
new file mode 100644
index 000000000..8dbc238b0
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/VectorElemMethod.F90
@@ -0,0 +1,68 @@
+! 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
+!
+SELECT CASE (obj%vartype)
+CASE (constant)
+
+ IF (obj%defineon .EQ. nodal) THEN
+
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableConstant)
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableConstant)
+
+CASE (space)
+
+ IF (obj%defineon .EQ. nodal) THEN
+
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableSpace, obj%s(1:2))
+ RETURN
+
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableSpace, obj%s(1:2))
+
+CASE (time)
+
+ IF (obj%defineon .EQ. nodal) THEN
+
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableTime, obj%s(1:2))
+
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableTime, obj%s(1:2))
+
+CASE (spacetime)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3))
+ RETURN
+ END IF
+
+ ans = QuadratureVariable(_ELEM_METHOD_(obj%val(1:obj%len)), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj%s(1:3))
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/VectorOperatorReal.F90 b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90
new file mode 100644
index 000000000..0aa58c55c
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/VectorOperatorReal.F90
@@ -0,0 +1,34 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableConstant)
+ END IF
+CASE (space)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableSpace, obj1%s(1:2))
+ END IF
+CASE (time)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableTime, obj1%s(1:2))
+ END IF
+CASE (spacetime)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ val, &
+ TypeFEVariableVector, TypeFEVariableSpaceTime, obj1%s(1:3))
+ END IF
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90 b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90
new file mode 100644
index 000000000..74b2a8ad8
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/VectorOperatorScalar.F90
@@ -0,0 +1,120 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableConstant)
+ END IF
+ CASE (space)
+ CALL Reallocate(r2, obj1%s(1), obj2%s(1))
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj)
+ END DO
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ END IF
+ DEALLOCATE (r2)
+ CASE (time)
+ CALL Reallocate(r2, obj1%s(1), obj2%s(1))
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(1:obj1%len) _OP_ obj2%val(jj)
+ END DO
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ END IF
+ DEALLOCATE (r2)
+ CASE (spacetime)
+ r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime)
+ CALL Reallocate(r3, obj1%s(1), SIZE(r2, 1), SIZE(r2, 2))
+ DO kk = 1, SIZE(r3, 3)
+ DO jj = 1, SIZE(r3, 2)
+ r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r2(jj, kk)
+ END DO
+ END DO
+ IF (obj2%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r3, typeFEVariableVector, &
+ typeFEVariableSpaceTime)
+ END IF
+ DEALLOCATE (r2, r3)
+ END SELECT
+CASE (space)
+ SELECT CASE (obj1%vartype)
+ CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2))
+ END IF
+ CASE (space)
+ r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj)
+ END DO
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableSpace)
+ END IF
+ DEALLOCATE (r2)
+ END SELECT
+CASE (time)
+ SELECT CASE (obj1%vartype)
+ CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableTime, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableTime, obj1%s(1:2))
+ END IF
+ CASE (time)
+ r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = r2(:, jj) _OP_ obj2%val(jj)
+ END DO
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r2, typeFEVariableVector, typeFEVariableTime)
+ END IF
+ DEALLOCATE (r2)
+ END SELECT
+CASE (spacetime)
+ SELECT CASE (obj1%vartype)
+ CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3))
+ END IF
+ CASE (spacetime)
+ r3 = GET(obj1, typeFEVariableVector, typeFEVariableSpaceTime)
+ r2 = GET(obj2, typeFEVariableScalar, typeFEVariableSpaceTime)
+ DO kk = 1, SIZE(r3, 3)
+ DO jj = 1, SIZE(r3, 2)
+ r3(:, jj, kk) = r3(:, jj, kk) _OP_ r2(jj, kk)
+ END DO
+ END DO
+ IF (obj1%defineon .EQ. Nodal) THEN
+ ans = NodalVariable(r3, typeFEVariableVector, typeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r3, typeFEVariableVector, &
+ typeFEVariableSpaceTime)
+ END IF
+ DEALLOCATE (r2, r3)
+ END SELECT
+END SELECT
diff --git a/src/submodules/FEVariable/src/include/VectorOperatorVector.F90 b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90
new file mode 100644
index 000000000..32e88ebf9
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/VectorOperatorVector.F90
@@ -0,0 +1,130 @@
+SELECT CASE (obj1%vartype)
+CASE (constant)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableConstant)
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableConstant)
+ END IF
+ CASE (space)
+ r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj)
+ END DO
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r2, &
+ typeFEVariableVector, typeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r2, &
+ typeFEVariableVector, typeFEVariableSpace)
+ END IF
+ DEALLOCATE (r2)
+ CASE (time)
+ r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = obj1%val(1:obj1%len) _OP_ r2(:, jj)
+ END DO
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r2, &
+ typeFEVariableVector, typeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r2, &
+ typeFEVariableVector, typeFEVariableTime)
+ END IF
+ DEALLOCATE (r2)
+ CASE (spacetime)
+ r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime)
+ DO kk = 1, SIZE(r3, 3)
+ DO jj = 1, SIZE(r3, 2)
+ r3(:, jj, kk) = obj1%val(1:obj1%len) _OP_ r3(:, jj, kk)
+ END DO
+ END DO
+ IF (obj2%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r3, &
+ typeFEVariableVector, typeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r3, &
+ typeFEVariableVector, typeFEVariableSpaceTime)
+ END IF
+ DEALLOCATE (r3)
+
+ END SELECT
+CASE (space)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len)
+ END DO
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r2, &
+ typeFEVariableVector, typeFEVariableSpace)
+ ELSE
+ ans = QuadratureVariable(r2, &
+ typeFEVariableVector, typeFEVariableSpace)
+ END IF
+ DEALLOCATE (r2)
+ CASE (space)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpace, obj1%s(1:2))
+ END IF
+ END SELECT
+CASE (time)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
+ DO jj = 1, SIZE(r2, 2)
+ r2(:, jj) = r2(:, jj) _OP_ obj2%val(1:obj2%len)
+ END DO
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r2, &
+ typeFEVariableVector, typeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r2, &
+ typeFEVariableVector, typeFEVariableTime)
+ END IF
+ CASE (time)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableTime, obj1%s(1:2))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableTime, obj1%s(1:2))
+ END IF
+ END SELECT
+CASE (spacetime)
+ SELECT CASE (obj2%vartype)
+ CASE (constant)
+ r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime)
+ DO kk = 1, SIZE(r3, 3)
+ DO jj = 1, SIZE(r3, 2)
+ r3(:, jj, kk) = r3(:, jj, kk) _OP_ obj2%val(1:obj2%len)
+ END DO
+ END DO
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r3, &
+ typeFEVariableVector, typeFEVariableSpaceTime)
+ ELSE
+ ans = QuadratureVariable(r3, &
+ typeFEVariableVector, typeFEVariableSpaceTime)
+ END IF
+ DEALLOCATE (r3)
+
+ CASE (spacetime)
+ IF (obj1%defineon .EQ. nodal) THEN
+ ans = NodalVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3))
+ ELSE
+ ans = QuadratureVariable(obj1%val(1:obj1%len) _OP_ obj2%val(1:obj2%len), &
+ typeFEVariableVector, typeFEVariableSpaceTime, obj1%s(1:3))
+ END IF
+ END SELECT
+
+END SELECT
diff --git a/src/submodules/FEVariable/src/VectorPower.inc b/src/submodules/FEVariable/src/include/VectorPower.F90
similarity index 75%
rename from src/submodules/FEVariable/src/VectorPower.inc
rename to src/submodules/FEVariable/src/include/VectorPower.F90
index b87932282..83bc64b8d 100644
--- a/src/submodules/FEVariable/src/VectorPower.inc
+++ b/src/submodules/FEVariable/src/include/VectorPower.F90
@@ -24,68 +24,68 @@
!!
CASE (constant)
!!
- IF( obj%defineon .EQ. nodal ) THEN
+ IF (obj%defineon .EQ. nodal) THEN
ans = NodalVariable( &
- & obj%val(:) ** n, &
+ & obj%val(:)**n, &
& typeFEVariableVector, &
& typeFEVariableConstant)
ELSE
ans = QuadratureVariable( &
- & obj%val(:) ** n, &
+ & obj%val(:)**n, &
& typeFEVariableVector, &
& typeFEVariableConstant)
- ENDIF
+ END IF
!!
!!
!!
!!
CASE (space)
!!
- IF( obj%defineon .EQ. nodal ) THEN
+ IF (obj%defineon .EQ. nodal) THEN
ans = NodalVariable(&
- & RESHAPE(obj%val(:) ** n, obj%s(1:2)), &
+ & RESHAPE(obj%val(:)**n, obj%s(1:2)), &
& typeFEVariableVector, &
& typeFEVariableSpace)
ELSE
ans = QuadratureVariable(&
- & RESHAPE(obj%val(:) ** n, obj%s(1:2)), &
+ & RESHAPE(obj%val(:)**n, obj%s(1:2)), &
& typeFEVariableVector, &
& typeFEVariableSpace)
- ENDIF
+ END IF
!!
!!
!!
!!
CASE (time)
!!
- IF( obj%defineon .EQ. nodal ) THEN
+ IF (obj%defineon .EQ. nodal) THEN
ans = NodalVariable( &
- & RESHAPE(obj%val(:) ** n, obj%s(1:2)), &
+ & RESHAPE(obj%val(:)**n, obj%s(1:2)), &
& typeFEVariableVector, &
& typeFEVariableTime)
ELSE
ans = QuadratureVariable( &
- & RESHAPE(obj%val(:) ** n, obj%s(1:2)), &
+ & RESHAPE(obj%val(:)**n, obj%s(1:2)), &
& typeFEVariableVector, &
& typeFEVariableTime)
- ENDIF
+ END IF
!!
!!
!!
!!
CASE (spacetime)
!!
- IF( obj%defineon .EQ. nodal ) THEN
+ IF (obj%defineon .EQ. nodal) THEN
ans = NodalVariable(&
- & RESHAPE(obj%val(:) ** n, obj%s(1:3)), &
+ & RESHAPE(obj%val(:)**n, obj%s(1:3)), &
& typeFEVariableVector, &
& typeFEVariableSpaceTime)
ELSE
ans = QuadratureVariable(&
- & RESHAPE(obj%val(:) ** n, obj%s(1:3)), &
+ & RESHAPE(obj%val(:)**n, obj%s(1:3)), &
& typeFEVariableVector, &
& typeFEVariableSpaceTime)
- ENDIF
+ END IF
!!
!!
!!
diff --git a/src/submodules/FEVariable/src/include/matrix_constant.F90 b/src/submodules/FEVariable/src/include/matrix_constant.F90
new file mode 100644
index 000000000..bb2d804b9
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_constant.F90
@@ -0,0 +1,19 @@
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+
+DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+
+obj%s(1:2) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = Constant
diff --git a/src/submodules/FEVariable/src/include/matrix_constant2.F90 b/src/submodules/FEVariable/src/include/matrix_constant2.F90
new file mode 100644
index 000000000..062b751b9
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:2) = s(1:2)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = Constant
diff --git a/src/submodules/FEVariable/src/include/matrix_space.F90 b/src/submodules/FEVariable/src/include/matrix_space.F90
new file mode 100644
index 000000000..0cd267920
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space.F90
@@ -0,0 +1,21 @@
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+
+DO kk = 1, SIZE(val, 3)
+ DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj, kk)
+ END DO
+ END DO
+END DO
+
+obj%s(1:3) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = Space
diff --git a/src/submodules/FEVariable/src/include/matrix_space2.F90 b/src/submodules/FEVariable/src/include/matrix_space2.F90
new file mode 100644
index 000000000..d9cd89b84
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:3) = s(1:3)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = Space
diff --git a/src/submodules/FEVariable/src/include/matrix_space_time.F90 b/src/submodules/FEVariable/src/include/matrix_space_time.F90
new file mode 100644
index 000000000..3a6463630
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space_time.F90
@@ -0,0 +1,23 @@
+INTEGER(I4B) :: ii, jj, kk, ll, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+
+DO ll = 1, SIZE(val, 4)
+ DO kk = 1, SIZE(val, 3)
+ DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj, kk, ll)
+ END DO
+ END DO
+ END DO
+END DO
+
+obj%s(1:4) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = SpaceTime
diff --git a/src/submodules/FEVariable/src/include/matrix_space_time2.F90 b/src/submodules/FEVariable/src/include/matrix_space_time2.F90
new file mode 100644
index 000000000..416f4d703
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:4) = s(1:4)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = SpaceTime
diff --git a/src/submodules/FEVariable/src/include/matrix_time.F90 b/src/submodules/FEVariable/src/include/matrix_time.F90
new file mode 100644
index 000000000..a4b831d86
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_time.F90
@@ -0,0 +1,21 @@
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+
+DO kk = 1, SIZE(val, 3)
+ DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj, kk)
+ END DO
+ END DO
+END DO
+
+obj%s(1:3) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = Time
diff --git a/src/submodules/FEVariable/src/include/matrix_time2.F90 b/src/submodules/FEVariable/src/include/matrix_time2.F90
new file mode 100644
index 000000000..aaa1007bb
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_time2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:3) = s(1:3)
+obj%defineOn = _DEFINEON_
+obj%rank = Matrix
+obj%varType = Time
diff --git a/src/submodules/FEVariable/src/include/scalar_constant.F90 b/src/submodules/FEVariable/src/include/scalar_constant.F90
new file mode 100644
index 000000000..628f7a7b6
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_constant.F90
@@ -0,0 +1,8 @@
+obj%len = 1
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1) = val
+obj%s(1) = 1
+obj%defineOn = _DEFINEON_
+obj%rank = Scalar
+obj%varType = Constant
diff --git a/src/submodules/FEVariable/src/include/scalar_space.F90 b/src/submodules/FEVariable/src/include/scalar_space.F90
new file mode 100644
index 000000000..c43d15d52
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_space.F90
@@ -0,0 +1,8 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1:obj%len) = val
+obj%s(1) = SIZE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = SCALAR
+obj%varType = Space
diff --git a/src/submodules/FEVariable/src/include/scalar_space_time.F90 b/src/submodules/FEVariable/src/include/scalar_space_time.F90
new file mode 100644
index 000000000..75ee2a726
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90
@@ -0,0 +1,18 @@
+INTEGER(I4B) :: ii, jj, kk
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+kk = 0
+DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ kk = kk + 1
+ obj%val(kk) = val(ii, jj)
+ END DO
+END DO
+
+obj%s(1:2) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = SCALAR
+obj%varType = SpaceTime
diff --git a/src/submodules/FEVariable/src/include/scalar_space_time2.F90 b/src/submodules/FEVariable/src/include/scalar_space_time2.F90
new file mode 100644
index 000000000..e85818d99
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90
@@ -0,0 +1,12 @@
+INTEGER(I4B) :: ii
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:2) = s(1:2)
+obj%defineOn = _DEFINEON_
+obj%rank = SCALAR
+obj%varType = SpaceTime
diff --git a/src/submodules/FEVariable/src/include/scalar_time.F90 b/src/submodules/FEVariable/src/include/scalar_time.F90
new file mode 100644
index 000000000..1a7b0d3e3
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_time.F90
@@ -0,0 +1,8 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1:obj%len) = val
+obj%s(1) = SIZE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = SCALAR
+obj%varType = Time
diff --git a/src/submodules/FEVariable/src/include/vector_constant.F90 b/src/submodules/FEVariable/src/include/vector_constant.F90
new file mode 100644
index 000000000..42125ac15
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_constant.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1:obj%len) = val
+
+obj%s(1:1) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = Constant
diff --git a/src/submodules/FEVariable/src/include/vector_space.F90 b/src/submodules/FEVariable/src/include/vector_space.F90
new file mode 100644
index 000000000..2d6a663ef
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space.F90
@@ -0,0 +1,18 @@
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+
+obj%s(1:2) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = Space
diff --git a/src/submodules/FEVariable/src/include/vector_space2.F90 b/src/submodules/FEVariable/src/include/vector_space2.F90
new file mode 100644
index 000000000..a2e7c5cbf
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:2) = s(1:2)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = Space
diff --git a/src/submodules/FEVariable/src/include/vector_space_time.F90 b/src/submodules/FEVariable/src/include/vector_space_time.F90
new file mode 100644
index 000000000..e8ee7a797
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space_time.F90
@@ -0,0 +1,21 @@
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+
+DO kk = 1, SIZE(val, 3)
+ DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj, kk)
+ END DO
+ END DO
+END DO
+
+obj%s(1:3) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = SpaceTime
diff --git a/src/submodules/FEVariable/src/include/vector_space_time2.F90 b/src/submodules/FEVariable/src/include/vector_space_time2.F90
new file mode 100644
index 000000000..a671d1408
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:3) = s(1:3)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = SpaceTime
diff --git a/src/submodules/FEVariable/src/include/vector_time.F90 b/src/submodules/FEVariable/src/include/vector_time.F90
new file mode 100644
index 000000000..7cc4a4a7f
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_time.F90
@@ -0,0 +1,18 @@
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+cnt = 0
+DO jj = 1, SIZE(val, 2)
+ DO ii = 1, SIZE(val, 1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+
+obj%s(1:2) = SHAPE(val)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = TIME
diff --git a/src/submodules/FEVariable/src/include/vector_time2.F90 b/src/submodules/FEVariable/src/include/vector_time2.F90
new file mode 100644
index 000000000..b3e52b512
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_time2.F90
@@ -0,0 +1,10 @@
+obj%len = SIZE(val)
+obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+ALLOCATE (obj%val(obj%capacity))
+
+obj%val(1:obj%len) = val(1:obj%len)
+
+obj%s(1:2) = s(1:2)
+obj%defineOn = _DEFINEON_
+obj%rank = Vector
+obj%varType = TIME
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90
index b9cf81703..e6d2ef714 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90
@@ -26,46 +26,46 @@
MODULE PROCEDURE FacetMatrix11_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns = nns1 + nns2
- nsd = masterElemSD%refelem%nsd
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns = nns1 + nns2
+nsd = masterElemSD%nsd
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP
+ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP
!!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips)
- END DO
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- ans = ans + &
- & realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
+ ans = ans + &
+ & realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
!!
- END DO
+END DO
!!
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1 )
+DEALLOCATE (realval, masterC1, slaveC1, C1)
!!
END PROCEDURE FacetMatrix11_1
@@ -75,49 +75,49 @@
MODULE PROCEDURE FacetMatrix11_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), slaveC1(:,:), &
- & C1( :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), slaveC1(:, :), &
+ & C1(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP
+ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- masterC1 = masterC1 * muMaster
- slaveC1 = slaveC1 * muSlave
+masterC1 = masterC1 * muMaster
+slaveC1 = slaveC1 * muSlave
!!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips)
- END DO
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- ans = ans &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
+ ans = ans &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
!!
- END DO
+END DO
!!
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1 )
+DEALLOCATE (realval, masterC1, slaveC1, C1)
!!
END PROCEDURE FacetMatrix11_2
@@ -127,50 +127,50 @@
MODULE PROCEDURE FacetMatrix11_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), taubar( : ), C1( :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), taubar(:), C1(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP
+ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar)
!!
- masterC1 = masterC1 * muMaster
- slaveC1 = slaveC1 * muSlave
+masterC1 = masterC1 * muMaster
+slaveC1 = slaveC1 * muSlave
!!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips)
- END DO
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * &
- & taubar
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * &
+ & taubar
!!
- DO ips = 1, nips
- ans = ans &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
+DO ips = 1, nips
+ ans = ans &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
!!
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
!!
- DEALLOCATE( realval, masterC1, slaveC1, taubar, C1 )
+DEALLOCATE (realval, masterC1, slaveC1, taubar, C1)
!!
END PROCEDURE FacetMatrix11_3
@@ -180,56 +180,56 @@
MODULE PROCEDURE FacetMatrix11_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & muMasterBar( : ), muSlaveBar( : ), slaveC1( :, : ), C1( :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & muMasterBar(:), muSlaveBar(:), slaveC1(:, :), C1(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- ALLOCATE( C1( nns, nips ), ans( nns, nns ) ); ans = 0.0_DFP
+ALLOCATE (C1(nns, nips), ans(nns, nns)); ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=muMasterBar, &
+ & val=muMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=muSlaveBar, &
+ & val=muSlave)
!!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips )
- slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips)
- END DO
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips)
+ slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
- ans = ans &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
+DO ips = 1, nips
+ ans = ans &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
!!
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, muMasterBar, muSlaveBar )
+DEALLOCATE (realval, masterC1, slaveC1, C1, muMasterBar, muSlaveBar)
!!
END PROCEDURE FacetMatrix11_4
@@ -239,63 +239,63 @@
MODULE PROCEDURE FacetMatrix11_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & muMasterBar( : ), muSlaveBar( : ), tauBar( : ), slaveC1( :, : ), &
- & C1(:,:)
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, slaveips, nns
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & muMasterBar(:), muSlaveBar(:), tauBar(:), slaveC1(:, :), &
+ & C1(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, slaveips, nns
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- ALLOCATE( C1( nns, nips ), ans( nns, nns ) )
+ALLOCATE (C1(nns, nips), ans(nns, nns))
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=muMasterBar, &
+ & val=muMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=muSlaveBar, &
+ & val=muSlave)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauBar, &
- & val=tauvar )
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=tauBar, &
+ & val=tauvar)
!!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- masterC1( :, ips ) = muMasterBar( ips ) * masterC1( :, ips )
- slaveC1( :, ips ) = muSlaveBar( ips ) * slaveC1( :, ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips)
- END DO
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips)
+ slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+END DO
!!
- realval = masterElemSD%js*masterElemSD%ws*masterElemSD%thickness*tauBar
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness * tauBar
!!
- DO ips = 1, nips
- ans = ans &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
+DO ips = 1, nips
+ ans = ans &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
!!
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
!!
- DEALLOCATE( realval, masterC1, slaveC1, muMasterBar, &
- & muSlaveBar, C1 )
+DEALLOCATE (realval, masterC1, slaveC1, muMasterBar, &
+ & muSlaveBar, C1)
!!
END PROCEDURE FacetMatrix11_5
@@ -303,4 +303,4 @@
!
!----------------------------------------------------------------------------
-END SUBMODULE FacetMatrix11Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix11Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90
index 85cd9bb10..584a75829 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix12Methods.F90
@@ -26,24 +26,24 @@
MODULE PROCEDURE FacetMatrix12_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : )
- INTEGER( I4B ) :: ips, nips, nns, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :)
+INTEGER(I4B) :: ips, nips, nns, nsd
!!
- nns = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- CALL Reallocate(ans, nns, nns)
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=C1, &
- & val=elemsd%normal )
- realval = elemsd%js * elemsd%ws * elemsd%thickness
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
- DEALLOCATE( realval, C1 )
+nns = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+CALL Reallocate(ans, nns, nns)
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=C1, &
+ & val=elemsd%normal)
+realval = elemsd%js * elemsd%ws * elemsd%thickness
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
+DEALLOCATE (realval, C1)
!!
END PROCEDURE FacetMatrix12_1
@@ -53,24 +53,24 @@
MODULE PROCEDURE FacetMatrix12_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : )
- INTEGER( I4B ) :: ips, nips, nns, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :)
+INTEGER(I4B) :: ips, nips, nns, nsd
!!
- nns = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- CALL Reallocate(ans, nns, nns)
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=C1, &
- & val=elemsd%normal )
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
- DEALLOCATE( realval, C1 )
+nns = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+CALL Reallocate(ans, nns, nns)
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=C1, &
+ & val=elemsd%normal)
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
+DEALLOCATE (realval, C1)
!!
END PROCEDURE FacetMatrix12_2
@@ -80,25 +80,25 @@
MODULE PROCEDURE FacetMatrix12_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), taubar( : )
- INTEGER( I4B ) :: ips, nips, nns, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :), taubar(:)
+INTEGER(I4B) :: ips, nips, nns, nsd
!!
- nns = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- CALL Reallocate(ans, nns, nns)
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=C1, &
- & val=elemsd%normal )
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
- realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
- DEALLOCATE( realval, C1, taubar )
+nns = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+CALL Reallocate(ans, nns, nns)
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=C1, &
+ & val=elemsd%normal)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
+DEALLOCATE (realval, C1, taubar)
!!
END PROCEDURE FacetMatrix12_3
@@ -108,22 +108,22 @@
MODULE PROCEDURE FacetMatrix12_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), muBar( : )
- INTEGER( I4B ) :: ips, nips, nns, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :), muBar(:)
+INTEGER(I4B) :: ips, nips, nns, nsd
!!
- nns = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- CALL Reallocate(ans, nns, nns)
- CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal )
- CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu )
- realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
- DEALLOCATE( realval, C1, muBar )
+nns = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+CALL Reallocate(ans, nns, nns)
+CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal)
+CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu)
+realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
+DEALLOCATE (realval, C1, muBar)
!!
END PROCEDURE FacetMatrix12_4
@@ -133,25 +133,25 @@
MODULE PROCEDURE FacetMatrix12_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), C1( :, : ), &
- & muBar( : ), tauBar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), C1(:, :), &
+ & muBar(:), tauBar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns, nsd
!!
- nns = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- CALL Reallocate(ans, nns, nns)
- CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal )
- CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu )
- CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar )
- realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips )*OUTERPROD( C1( :, ips ), C1( :, ips ) )
- END DO
- IF( PRESENT( nCopy ) ) CALL MakeDiagonalCopies(ans, nCopy)
- DEALLOCATE( realval, C1, muBar )
+nns = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+CALL Reallocate(ans, nns, nns)
+CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=C1, val=elemsd%normal)
+CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu)
+CALL getInterpolation(obj=elemsd, interpol=tauBar, val=tauvar)
+realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C1(:, ips))
+END DO
+IF (PRESENT(nCopy)) CALL MakeDiagonalCopies(ans, nCopy)
+DEALLOCATE (realval, C1, muBar)
!!
END PROCEDURE FacetMatrix12_5
-END SUBMODULE FacetMatrix12Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix12Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90
index 124c1dc20..d48566e36 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90
@@ -26,251 +26,250 @@
MODULE PROCEDURE FacetMatrix13_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
- !!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nns2 = SIZE( elemsd%N, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), &
- & elemsd%N( :, ips ) )
- END DO
- END DO
- END DO
- !!
- CALL Convert( from=m4, to=ans )
- !!
- DEALLOCATE( m4, realval, masterC1 )
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+ !!
+nns1 = SIZE(elemsd%dNdXt, 1)
+nns2 = SIZE(elemsd%N, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
-END PROCEDURE FacetMatrix13_1
-
-!----------------------------------------------------------------------------
-! FacetMatrix13
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE FacetMatrix13_2
+realval = elemsd%js * elemsd%ws * elemsd%thickness
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
- !!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nns2 = SIZE( elemsd%N, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), &
- & elemsd%N( :, ips ) )
- END DO
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), &
+ & elemsd%N(:, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1 )
+DEALLOCATE (m4, realval, masterC1)
!!
-END PROCEDURE FacetMatrix13_2
+END PROCEDURE FacetMatrix13_1
!----------------------------------------------------------------------------
! FacetMatrix13
!----------------------------------------------------------------------------
-MODULE PROCEDURE FacetMatrix13_3
+MODULE PROCEDURE FacetMatrix13_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nns2 = SIZE( elemsd%N, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nns2 = SIZE(elemsd%N, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
+CALL getProjectionOfdNdXt( &
& obj=elemsd, &
& cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+ & val=elemsd%normal)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
!!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), &
- & elemsd%N( :, ips ) )
- END DO
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), &
+ & elemsd%N(:, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, taubar )
+DEALLOCATE (m4, realval, masterC1)
!!
-END PROCEDURE FacetMatrix13_3
-
+END PROCEDURE FacetMatrix13_2
!----------------------------------------------------------------------------
! FacetMatrix13
!----------------------------------------------------------------------------
-MODULE PROCEDURE FacetMatrix13_4
+MODULE PROCEDURE FacetMatrix13_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : ), mubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
- !!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nns2 = SIZE( elemsd%N, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), &
- & elemsd%N( :, ips ) )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :), taubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+ !!
+nns1 = SIZE(elemsd%dNdXt, 1)
+nns2 = SIZE(elemsd%N, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+& obj=elemsd, &
+& cdNdXt=masterC1, &
+& val=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), &
+ & elemsd%N(:, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, mubar )
+DEALLOCATE (m4, realval, masterC1, taubar)
!!
-END PROCEDURE FacetMatrix13_4
+END PROCEDURE FacetMatrix13_3
!----------------------------------------------------------------------------
! FacetMatrix13
!----------------------------------------------------------------------------
-MODULE PROCEDURE FacetMatrix13_5
+MODULE PROCEDURE FacetMatrix13_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : ), mubar( : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :), mubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nns2 = SIZE( elemsd%N, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nns2 = SIZE(elemsd%N, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
+CALL getProjectionOfdNdXt( &
& obj=elemsd, &
& cdNdXt=masterC1, &
- & val=elemsd%normal )
+ & val=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), &
+ & elemsd%N(:, ips))
+ END DO
+ END DO
+END DO
+ !!
+CALL Convert(from=m4, to=ans)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+DEALLOCATE (m4, realval, masterC1, mubar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+END PROCEDURE FacetMatrix13_4
+
+!----------------------------------------------------------------------------
+! FacetMatrix13
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FacetMatrix13_5
!!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ), &
- & elemsd%N( :, ips ) )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :), mubar(:), taubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+ !!
+nns1 = SIZE(elemsd%dNdXt, 1)
+nns2 = SIZE(elemsd%N, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+& obj=elemsd, &
+& cdNdXt=masterC1, &
+& val=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips), &
+ & elemsd%N(:, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, mubar, taubar )
+DEALLOCATE (m4, realval, masterC1, mubar, taubar)
!!
END PROCEDURE FacetMatrix13_5
-END SUBMODULE FacetMatrix13Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix13Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90
index 805bf3938..f9979feae 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix14Methods.F90
@@ -26,45 +26,45 @@
MODULE PROCEDURE FacetMatrix14_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2
- !!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2
+ !!
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
+ !!
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1 )
+DEALLOCATE (m4, realval, masterC1)
!!
END PROCEDURE FacetMatrix14_1
@@ -74,45 +74,45 @@
MODULE PROCEDURE FacetMatrix14_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2
- !!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, jj, nsd1, nsd2
+ !!
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1 )
+DEALLOCATE (m4, realval, masterC1)
!!
END PROCEDURE FacetMatrix14_2
@@ -122,99 +122,98 @@
MODULE PROCEDURE FacetMatrix14_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
- !!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- !!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu* taubar
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :), taubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
+ !!
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+& obj=elemsd, &
+& cdNdXt=masterC1, &
+& val=elemsd%normal)
+ !!
+ !!
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, taubar )
+DEALLOCATE (m4, realval, masterC1, taubar)
!!
END PROCEDURE FacetMatrix14_3
-
!----------------------------------------------------------------------------
! FacetMatrix14
!----------------------------------------------------------------------------
MODULE PROCEDURE FacetMatrix14_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : ), mubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
- !!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
- !!
- DO ips = 1, nips
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :), mubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
+ !!
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
+ !!
+DO ips = 1, nips
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips))
END DO
END DO
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, mubar )
+DEALLOCATE (m4, realval, masterC1, mubar)
!!
END PROCEDURE FacetMatrix14_4
@@ -224,53 +223,53 @@
MODULE PROCEDURE FacetMatrix14_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & m4( :, :, :, : ), mubar( : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
- !!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & m4(:, :, :, :), mubar(:), taubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
+ !!
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getProjectionOfdNdXt( &
+& obj=elemsd, &
+& cdNdXt=masterC1, &
+& val=elemsd%normal)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- DO ips = 1, nips
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+ !!
+DO ips = 1, nips
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ) * elemsd%normal( ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips) * elemsd%normal(ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, mubar, taubar )
+DEALLOCATE (m4, realval, masterC1, mubar, taubar)
!!
END PROCEDURE FacetMatrix14_5
-END SUBMODULE FacetMatrix14Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix14Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90
index 45b5cddd3..41aaef053 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix15Methods.F90
@@ -26,66 +26,66 @@
MODULE PROCEDURE FacetMatrix15_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- IF( opt .EQ. 1 ) THEN
- !!
- nsd1 = nsd
- nsd2 = 1
- !!
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) )
- m4 = 0.0_DFP
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips )
- !!
- C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips)
- C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips)
- END DO
- !!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
- !!
- DO ips = 1, nips
- !!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+IF (opt .EQ. 1) THEN
+ !!
+ nsd1 = nsd
+ nsd2 = 1
+ !!
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2))
+m4 = 0.0_DFP
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+ !!
+ C2(1:nns1, :, ips) = 0.5_DFP * masterElemSD%dNdXt(:, :, ips)
+ C2(nns1 + 1:, :, ips) = 0.5_DFP * slaveElemSD%dNdXt(:, :, slaveips)
+END DO
+ !!
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+ !!
+DO ips = 1, nips
+ !!
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 )
+DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4)
!!
END PROCEDURE FacetMatrix15_1
@@ -95,69 +95,69 @@
MODULE PROCEDURE FacetMatrix15_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- IF( opt .EQ. 1 ) THEN
- !!
- nsd1 = nsd
- nsd2 = 1
- !!
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) )
- m4 = 0.0_DFP
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- masterC1 = muMaster * masterC1
- slaveC1 = muSlave * slaveC1
- !!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips )
- !!
- C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips)
- C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips)
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+IF (opt .EQ. 1) THEN
+ !!
+ nsd1 = nsd
+ nsd2 = 1
+ !!
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2))
+m4 = 0.0_DFP
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- DO ips = 1, nips
+masterC1 = muMaster * masterC1
+slaveC1 = muSlave * slaveC1
+ !!
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+ !!
+ C2(1:nns1, :, ips) = 0.5_DFP * masterElemSD%dNdXt(:, :, ips)
+ C2(nns1 + 1:, :, ips) = 0.5_DFP * slaveElemSD%dNdXt(:, :, slaveips)
+END DO
+ !!
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+ !!
+DO ips = 1, nips
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 )
+DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4)
!!
END PROCEDURE FacetMatrix15_2
@@ -167,71 +167,71 @@
MODULE PROCEDURE FacetMatrix15_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- IF( opt .EQ. 1 ) THEN
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+IF (opt .EQ. 1) THEN
!!
- nsd1 = nsd
- nsd2 = 1
+ nsd1 = nsd
+ nsd2 = 1
!!
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) )
- m4 = 0.0_DFP
+ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2))
+m4 = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- masterC1 = muMaster * masterC1
- slaveC1 = muSlave * slaveC1
+masterC1 = muMaster * masterC1
+slaveC1 = muSlave * slaveC1
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips )
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
!!
- C2(1:nns1, :, ips)=(0.5_DFP*tauMaster)*masterElemSD%dNdXt(:,:,ips)
- C2(nns1+1:, :, ips)=(0.5_DFP*tauSlave)*slaveElemSD%dNdXt(:, :, slaveips)
+ C2(1:nns1, :, ips) = (0.5_DFP * tauMaster) * masterElemSD%dNdXt(:, :, ips)
+ C2(nns1+1:, :, ips)=(0.5_DFP*tauSlave)*slaveElemSD%dNdXt(:, :, slaveips)
!!
- END DO
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4 )
+DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4)
!!
END PROCEDURE FacetMatrix15_3
@@ -241,80 +241,80 @@
MODULE PROCEDURE FacetMatrix15_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & muMasterBar( : ), muSlaveBar( : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & muMasterBar(:), muSlaveBar(:)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- IF( opt .EQ. 1 ) THEN
+IF (opt .EQ. 1) THEN
!!
- nsd1 = nsd
- nsd2 = 1
+ nsd1 = nsd
+ nsd2 = 1
!!
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
!!
- ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) )
- m4 = 0.0_DFP
+ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2))
+m4 = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=muMasterBar, &
+ & val=muMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=muSlaveBar, &
+ & val=muSlave)
!!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips )
- C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips )
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = muMasterBar(ips) * masterC1(:, ips)
+ C1(1 + nns1:, ips) = muSlaveBar(ips) * slaveC1(:, ips)
!!
- C2(1:nns1, :, ips)=0.5_DFP*masterElemSD%dNdXt(:,:,ips)
- C2(nns1+1:, :, ips)=0.5_DFP*slaveElemSD%dNdXt(:, :, slaveips)
- END DO
+ C2(1:nns1, :, ips) = 0.5_DFP * masterElemSD%dNdXt(:, :, ips)
+ C2(nns1 + 1:, :, ips) = 0.5_DFP * slaveElemSD%dNdXt(:, :, slaveips)
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, muMasterBar, &
- & muSlaveBar )
+DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4, muMasterBar, &
+ & muSlaveBar)
!!
END PROCEDURE FacetMatrix15_4
@@ -324,83 +324,83 @@
MODULE PROCEDURE FacetMatrix15_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & tauMasterBar( : ), tauSlaveBar( : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- IF( opt .EQ. 1 ) THEN
- !!
- nsd1 = nsd
- nsd2 = 1
- !!
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) )
- m4 = 0.0_DFP
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauMasterBar, &
- & val=tauMaster )
- !!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=tauSlaveBar, &
- & val=tauSlave )
- !!
- masterC1 = muMaster * masterC1
- slaveC1 = muSlave * slaveC1
- !!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = masterC1(:, ips)
- C1( 1+nns1:, ips ) = slaveC1(:, slaveips )
- !!
- C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips)
- C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) &
- & *slaveElemSD%dNdXt(:, :, slaveips)
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & tauMasterBar(:), tauSlaveBar(:)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+IF (opt .EQ. 1) THEN
!!
- END DO
+ nsd1 = nsd
+ nsd2 = 1
+ !!
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2))
+m4 = 0.0_DFP
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=tauMasterBar, &
+ & val=tauMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=tauSlaveBar, &
+ & val=tauSlave)
+ !!
+masterC1 = muMaster * masterC1
+slaveC1 = muSlave * slaveC1
+ !!
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = masterC1(:, ips)
+ C1(1 + nns1:, ips) = slaveC1(:, slaveips)
+ !!
+ C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips)
+ C2(nns1 + 1:, :, ips) = (0.5_DFP * tauSlaveBar(slaveips)) &
+ & * slaveElemSD%dNdXt(:, :, slaveips)
+ !!
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, &
- & tauSlaveBar )
+DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, &
+ & tauSlaveBar)
!!
END PROCEDURE FacetMatrix15_5
@@ -410,92 +410,92 @@
MODULE PROCEDURE FacetMatrix15_6
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & tauMasterBar( : ), tauSlaveBar( : ), muMasterBar( : ), &
- & muSlaveBar( : ), C( : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- IF( opt .EQ. 1 ) THEN
- !!
- nsd1 = nsd
- nsd2 = 1
- !!
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( C1( nns, nips ), C2( nns, nsd, nips ), m4( nns, nns, nsd1, nsd2) )
- m4 = 0.0_DFP
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
- !!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
- !!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauMasterBar, &
- & val=tauMaster )
- !!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=tauSlaveBar, &
- & val=tauSlave )
- !!
- DO ips = 1, nips
- slaveips = quadMap( ips )
- C1( 1:nns1, ips ) = muMasterBar( ips ) * masterC1( :, ips )
- C1( 1+nns1:, ips ) = muSlaveBar( ips ) * slaveC1( :, ips )
- !!
- C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips)
- C2(nns1+1:, :, ips)=(0.5_DFP*tauSlaveBar(slaveips)) &
- & *slaveElemSD%dNdXt(:, :, slaveips)
- !!
- END DO
- !!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
- !!
- DO ips = 1, nips
- !!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & tauMasterBar(:), tauSlaveBar(:), muMasterBar(:), &
+ & muSlaveBar(:), C(:)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+IF (opt .EQ. 1) THEN
+ !!
+ nsd1 = nsd
+ nsd2 = 1
+ !!
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE (C1(nns, nips), C2(nns, nsd, nips), m4(nns, nns, nsd1, nsd2))
+m4 = 0.0_DFP
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=muMasterBar, &
+ & val=muMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=muSlaveBar, &
+ & val=muSlave)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=tauMasterBar, &
+ & val=tauMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=tauSlaveBar, &
+ & val=tauSlave)
+ !!
+DO ips = 1, nips
+ slaveips = quadMap(ips)
+ C1(1:nns1, ips) = muMasterBar(ips) * masterC1(:, ips)
+ C1(1 + nns1:, ips) = muSlaveBar(ips) * slaveC1(:, ips)
+ !!
+ C2(1:nns1, :, ips)=(0.5_DFP*tauMasterBar(ips))*masterElemSD%dNdXt(:,:,ips)
+ C2(nns1 + 1:, :, ips) = (0.5_DFP * tauSlaveBar(slaveips)) &
+ & * slaveElemSD%dNdXt(:, :, slaveips)
+ !!
+END DO
+ !!
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+ !!
+DO ips = 1, nips
+ !!
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( C1(:,ips), C2(:, ii+jj-1, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD(C1(:, ips), C2(:, ii + jj - 1, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, &
- & tauSlaveBar, muMasterBar, muSlaveBar )
+DEALLOCATE (realval, masterC1, slaveC1, C1, C2, m4, tauMasterBar, &
+ & tauSlaveBar, muMasterBar, muSlaveBar)
!!
END PROCEDURE FacetMatrix15_6
-END SUBMODULE FacetMatrix15Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix15Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90
index eb6aed951..cf3741f65 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix1Methods.F90
@@ -26,63 +26,63 @@
MODULE PROCEDURE FacetMatrix1_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemSD, &
- & cdNdXt=masterC1, &
- & val=masterElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemSD, &
+ & cdNdXt=masterC1, &
+ & val=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemSD%normal)
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- CALL Reallocate( G12, nns1+nns2, nsd, nsd )
- CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd )
+CALL Reallocate(G12, nns1 + nns2, nsd, nsd)
+CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 )
+DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3)
!!
END PROCEDURE FacetMatrix1_1
@@ -92,63 +92,63 @@
MODULE PROCEDURE FacetMatrix1_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemSD, &
- & cdNdXt=masterC1, &
- & val=masterElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemSD, &
+ & cdNdXt=masterC1, &
+ & val=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemSD%normal)
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- CALL Reallocate( G12, nns1+nns2, nsd, nsd )
- CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd )
+CALL Reallocate(G12, nns1 + nns2, nsd, nsd)
+CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = muMaster*OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = muMaster * OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + muMaster * OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = muSlave*OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = muSlave * OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + muSlave * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3 )
+DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3)
!!
END PROCEDURE FacetMatrix1_2
@@ -158,67 +158,67 @@
MODULE PROCEDURE FacetMatrix1_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), &
- & taubar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :), &
+ & taubar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemSD, &
- & cdNdXt=masterC1, &
- & val=masterElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemSD, &
+ & cdNdXt=masterC1, &
+ & val=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemSD%normal)
!!
- CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar)
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- CALL Reallocate( G12, nns1+nns2, nsd, nsd )
- CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd )
+CALL Reallocate(G12, nns1 + nns2, nsd, nsd)
+CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness &
- & * taubar
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness &
+ & * taubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = muMaster*OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + muMaster*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = muMaster * OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + muMaster * OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = muSlave*OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + muSlave*OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = muSlave * OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + muSlave * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, taubar )
+DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3, taubar)
!!
END PROCEDURE FacetMatrix1_3
@@ -228,70 +228,70 @@
MODULE PROCEDURE FacetMatrix1_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), &
- & muMasterBar( : ), muSlaveBar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :), &
+ & muMasterBar(:), muSlaveBar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemSD, &
- & cdNdXt=masterC1, &
- & val=masterElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemSD, &
+ & cdNdXt=masterC1, &
+ & val=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemSD%normal)
!!
- CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, &
- & val=muMaster )
- CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, &
- & val=muSlave )
+CALL getInterpolation(obj=masterElemSD, interpol=muMasterBar, &
+ & val=muMaster)
+CALL getInterpolation(obj=slaveElemSD, interpol=muSlaveBar, &
+ & val=muSlave)
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- CALL Reallocate( G12, nns1+nns2, nsd, nsd )
- CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd )
+CALL Reallocate(G12, nns1 + nns2, nsd, nsd)
+CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = muMasterBar(ips) * OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + muMasterBar(ips) * OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = muSlaveBar(slaveips) * OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + muSlaveBar(slaveips) * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, &
- & muSlaveBar )
+DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, &
+ & muSlaveBar)
!!
END PROCEDURE FacetMatrix1_4
@@ -301,73 +301,73 @@
MODULE PROCEDURE FacetMatrix1_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), m4( :, :, :, : ), G12( :, :, : ), i3( :, : ), &
- & muMasterBar( : ), muSlaveBar( : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), m4(:, :, :, :), G12(:, :, :), i3(:, :), &
+ & muMasterBar(:), muSlaveBar(:), taubar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nns2, nsd, slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemSD, &
- & cdNdXt=masterC1, &
- & val=masterElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemSD, &
+ & cdNdXt=masterC1, &
+ & val=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemSD%normal)
!!
- CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, &
- & val=muMaster )
- CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, &
- & val=muSlave )
- CALL getInterpolation( obj=masterElemSD, interpol=taubar, val=tauvar )
+CALL getInterpolation(obj=masterElemSD, interpol=muMasterBar, &
+ & val=muMaster)
+CALL getInterpolation(obj=slaveElemSD, interpol=muSlaveBar, &
+ & val=muSlave)
+CALL getInterpolation(obj=masterElemSD, interpol=taubar, val=tauvar)
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- CALL Reallocate( G12, nns1+nns2, nsd, nsd )
- CALL Reallocate( m4, nns1+nns2, nns1+nns2, nsd, nsd )
+CALL Reallocate(G12, nns1 + nns2, nsd, nsd)
+CALL Reallocate(m4, nns1 + nns2, nns1 + nns2, nsd, nsd)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness &
- & * taubar
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness &
+ & * taubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = muMasterBar( ips )*OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + muMasterBar( ips )*OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = muMasterBar(ips) * OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + muMasterBar(ips) * OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = muSlaveBar( slaveips )*OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + muSlaveBar(slaveips)*OUTERPROD(slaveElemSD%dNdXt(:,:,slaveips), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = muSlaveBar(slaveips) * OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + muSlaveBar(slaveips) * OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, &
- & muSlaveBar, taubar )
+DEALLOCATE (realval, masterC1, slaveC1, m4, G12, i3, muMasterBar, &
+ & muSlaveBar, taubar)
!!
END PROCEDURE FacetMatrix1_5
-END SUBMODULE FacetMatrix1Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix1Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90
index 275164a2f..7c67006be 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix21Methods.F90
@@ -26,31 +26,31 @@
MODULE PROCEDURE FacetMatrix21_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : )
- INTEGER( I4B ) :: ips, nips, nns2, nns1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :)
+INTEGER(I4B) :: ips, nips, nns2, nns1
!!
- nns1 = SIZE( elemsd%N, 1 )
- nns2 = SIZE( elemsd%dNdXt, 1 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%N, 1)
+nns2 = SIZE(elemsd%dNdXt, 1)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- ALLOCATE( ans( nns1, nns2 ) )
- ans = 0.0_DFP
+ALLOCATE (ans(nns1, nns2))
+ans = 0.0_DFP
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
+realval = elemsd%js * elemsd%ws * elemsd%thickness
!!
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ))
- END DO
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips))
+END DO
!!
- DEALLOCATE( realval, masterC1 )
+DEALLOCATE (realval, masterC1)
!!
END PROCEDURE FacetMatrix21_1
@@ -60,31 +60,31 @@
MODULE PROCEDURE FacetMatrix21_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : )
- INTEGER( I4B ) :: ips, nips, nns2, nns1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :)
+INTEGER(I4B) :: ips, nips, nns2, nns1
!!
- nns1 = SIZE( elemsd%N, 1 )
- nns2 = SIZE( elemsd%dNdXt, 1 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%N, 1)
+nns2 = SIZE(elemsd%dNdXt, 1)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- ALLOCATE( ans( nns1, nns2 ) )
- ans = 0.0_DFP
+ALLOCATE (ans(nns1, nns2))
+ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar
!!
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ))
- END DO
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips))
+END DO
!!
- DEALLOCATE( realval, masterC1 )
+DEALLOCATE (realval, masterC1)
!!
END PROCEDURE FacetMatrix21_2
@@ -94,34 +94,34 @@
MODULE PROCEDURE FacetMatrix21_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), taubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
!!
- nns1 = SIZE( elemsd%N, 1 )
- nns2 = SIZE( elemsd%dNdXt, 1 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%N, 1)
+nns2 = SIZE(elemsd%dNdXt, 1)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- ALLOCATE( ans( nns1, nns2 ) )
- ans = 0.0_DFP
+ALLOCATE (ans(nns1, nns2))
+ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar
!!
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & masterC1( :, ips ))
- END DO
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & masterC1(:, ips))
+END DO
!!
- DEALLOCATE( realval, masterC1, taubar )
+DEALLOCATE (realval, masterC1, taubar)
!!
END PROCEDURE FacetMatrix21_3
-END SUBMODULE FacetMatrix21Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix21Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90
index 0f18edd6e..ef4a4f7ee 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix22Methods.F90
@@ -26,31 +26,31 @@
MODULE PROCEDURE FacetMatrix22_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : )
- INTEGER( I4B ) :: ips, nips, nns2, nns1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :)
+INTEGER(I4B) :: ips, nips, nns2, nns1
!!
- nns1 = SIZE( elemsd%N, 1 )
- nns2 = SIZE( elemsd%dNdXt, 1 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%N, 1)
+nns2 = SIZE(elemsd%dNdXt, 1)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- ALLOCATE( ans( nns2, nns1 ) )
- ans = 0.0_DFP
+ALLOCATE (ans(nns2, nns1))
+ans = 0.0_DFP
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
+realval = elemsd%js * elemsd%ws * elemsd%thickness
!!
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ), &
- & elemsd%N( :, ips ))
- END DO
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips), &
+ & elemsd%N(:, ips))
+END DO
!!
- DEALLOCATE( realval, masterC1 )
+DEALLOCATE (realval, masterC1)
!!
END PROCEDURE FacetMatrix22_1
@@ -60,31 +60,31 @@
MODULE PROCEDURE FacetMatrix22_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : )
- INTEGER( I4B ) :: ips, nips, nns2, nns1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :)
+INTEGER(I4B) :: ips, nips, nns2, nns1
!!
- nns1 = SIZE( elemsd%N, 1 )
- nns2 = SIZE( elemsd%dNdXt, 1 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%N, 1)
+nns2 = SIZE(elemsd%dNdXt, 1)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- ALLOCATE( ans( nns2, nns1 ) )
- ans = 0.0_DFP
+ALLOCATE (ans(nns2, nns1))
+ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * tauvar
!!
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ), &
- & elemsd%N( :, ips ))
- END DO
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips), &
+ & elemsd%N(:, ips))
+END DO
!!
- DEALLOCATE( realval, masterC1 )
+DEALLOCATE (realval, masterC1)
!!
END PROCEDURE FacetMatrix22_2
@@ -94,34 +94,34 @@
MODULE PROCEDURE FacetMatrix22_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), taubar(:)
+INTEGER(I4B) :: ips, ii, nips, nns2, nns1, nsd, nsd1, nsd2, jj
!!
- nns1 = SIZE( elemsd%N, 1 )
- nns2 = SIZE( elemsd%dNdXt, 1 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%N, 1)
+nns2 = SIZE(elemsd%dNdXt, 1)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- ALLOCATE( ans( nns2, nns ) )
- ans = 0.0_DFP
+ALLOCATE (ans(nns2, nns))
+ans = 0.0_DFP
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar
!!
- DO ips = 1, nips
- ans( :, : ) = ans( :, : ) &
- & + realval( ips ) * OUTERPROD( &
- & masterC1( :, ips ), &
- & elemsd%N( :, ips ))
- END DO
+DO ips = 1, nips
+ ans(:, :) = ans(:, :) &
+ & + realval(ips) * OUTERPROD( &
+ & masterC1(:, ips), &
+ & elemsd%N(:, ips))
+END DO
!!
- DEALLOCATE( realval, masterC1, taubar )
+DEALLOCATE (realval, masterC1, taubar)
!!
END PROCEDURE FacetMatrix22_3
-END SUBMODULE FacetMatrix22Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix22Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90
index 37485f0e5..bf1ab204f 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90
@@ -26,47 +26,47 @@
MODULE PROCEDURE FacetMatrix2_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns1, nsd, nsd)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns1, nsd, nsd)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
+realval = elemsd%js * elemsd%ws * elemsd%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, G12, m4 )
+DEALLOCATE (realval, masterC1, G12, m4)
!!
END PROCEDURE FacetMatrix2_1
@@ -76,45 +76,45 @@
MODULE PROCEDURE FacetMatrix2_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns1, nsd, nsd)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns1, nsd, nsd)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * mu
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, G12, m4 )
+DEALLOCATE (realval, masterC1, G12, m4)
!!
END PROCEDURE FacetMatrix2_2
@@ -124,47 +124,47 @@
MODULE PROCEDURE FacetMatrix2_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), taubar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), taubar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu
+realval = elemsd%js * elemsd%ws * elemsd%thickness * taubar * mu * mu
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns1, nsd, nsd)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns1, nsd, nsd)
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, G12, taubar, m4 )
+DEALLOCATE (realval, masterC1, G12, taubar, m4)
!!
END PROCEDURE FacetMatrix2_3
@@ -174,45 +174,45 @@
MODULE PROCEDURE FacetMatrix2_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), muBar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), muBar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal )
- CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu )
+CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal)
+CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu)
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns1, nsd, nsd)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns1, nsd, nsd)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * muBar * muBar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, G12, muBar, m4 )
+DEALLOCATE (realval, masterC1, G12, muBar, m4)
!!
END PROCEDURE FacetMatrix2_4
@@ -222,47 +222,47 @@
MODULE PROCEDURE FacetMatrix2_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), muBar( : ), &
- & tauBar( : )
- INTEGER( I4B ) :: ips, ii, jj, nips, nns1, nsd
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), muBar(:), &
+ & tauBar(:)
+INTEGER(I4B) :: ips, ii, jj, nips, nns1, nsd
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
!!
- CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal )
- CALL getInterpolation( obj=elemsd, interpol=muBar, val=mu )
- CALL getInterpolation( obj=elemsd, interpol=tauBar, val=tauvar )
+CALL getProjectionOfdNdXt(obj=elemsd, cdNdXt=masterC1, val=elemsd%normal)
+CALL getInterpolation(obj=elemsd, interpol=muBar, val=mu)
+CALL getInterpolation(obj=elemsd, interpol=tauBar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * tauBar * muBar * muBar
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns1, nsd, nsd)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns1, nsd, nsd)
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * MATMUL( G12( :, :, ii ), &
- & TRANSPOSE( G12( :, :, jj ) ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii), &
+ & TRANSPOSE(G12(:, :, jj)))
!!
- END DO
- !!
END DO
- !!
+ !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, G12, muBar, taubar, m4 )
+DEALLOCATE (realval, masterC1, G12, muBar, taubar, m4)
!!
END PROCEDURE FacetMatrix2_5
@@ -270,4 +270,4 @@
!
!----------------------------------------------------------------------------
-END SUBMODULE FacetMatrix2Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix2Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90
index bc9995afb..9756a37c1 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix3Methods.F90
@@ -26,55 +26,55 @@
MODULE PROCEDURE FacetMatrix3_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj
- !!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- nns2 = SIZE( elemsd%N, 1 )
- i3 = Eye( nsd )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
- !!
- DO ips = 1, nips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj
+ !!
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+nns2 = SIZE(elemsd%N, 1)
+i3 = Eye(nsd)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness
+ !!
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), &
- & elemsd%N( :, ips ) )
- END DO
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), &
+ & elemsd%N(:, ips))
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, i3)
!!
END PROCEDURE FacetMatrix3_1
@@ -84,55 +84,55 @@
MODULE PROCEDURE FacetMatrix3_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- nns2 = SIZE( elemsd%N, 1 )
- i3 = Eye( nsd )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+nns2 = SIZE(elemsd%N, 1)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), &
- & elemsd%N( :, ips ) )
- END DO
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), &
+ & elemsd%N(:, ips))
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12 )
+DEALLOCATE (m4, realval, masterC1, G12)
!!
END PROCEDURE FacetMatrix3_2
@@ -142,57 +142,57 @@
MODULE PROCEDURE FacetMatrix3_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), taubar(:), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- nns2 = SIZE( elemsd%N, 1 )
- i3 = Eye( nsd )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+nns2 = SIZE(elemsd%N, 1)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), &
- & elemsd%N( :, ips ) )
- END DO
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), &
+ & elemsd%N(:, ips))
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, taubar, i3)
!!
END PROCEDURE FacetMatrix3_3
@@ -202,59 +202,59 @@
MODULE PROCEDURE FacetMatrix3_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), mubar(:), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- nns2 = SIZE( elemsd%N, 1 )
- i3 = Eye( nsd )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+nns2 = SIZE(elemsd%N, 1)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), &
- & elemsd%N( :, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), &
+ & elemsd%N(:, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, mubar, i3)
!!
END PROCEDURE FacetMatrix3_4
@@ -264,61 +264,61 @@
MODULE PROCEDURE FacetMatrix3_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), mubar(:), taubar(:), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
!!
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- nns2 = SIZE( elemsd%N, 1 )
- i3 = Eye( nsd )
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+nns2 = SIZE(elemsd%N, 1)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns1, nns2, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), eye( nsd, 1.0_DFP ) ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), eye(nsd, 1.0_DFP)) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips ) ), &
- & elemsd%N( :, ips ) )
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)), &
+ & elemsd%N(:, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar )
+DEALLOCATE (m4, realval, masterC1, G12, mubar, taubar)
!!
END PROCEDURE FacetMatrix3_5
-END SUBMODULE FacetMatrix3Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix3Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90
index c685e4619..fa6f400a6 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix4Methods.F90
@@ -26,57 +26,57 @@
MODULE PROCEDURE FacetMatrix4_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj
- !!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- i3 = Eye( nsd )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
- !!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
- !!
- realval = elemsd%js * elemsd%ws * elemsd%thickness
- !!
- DO ips = 1, nips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd1, nsd2, nsd, jj
+ !!
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+i3 = Eye(nsd)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
+ !!
+realval = elemsd%js * elemsd%ws * elemsd%thickness
+ !!
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips )))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, i3)
!!
END PROCEDURE FacetMatrix4_1
@@ -86,57 +86,57 @@
MODULE PROCEDURE FacetMatrix4_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
!!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- i3 = Eye( nsd )
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips )))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, i3)
!!
END PROCEDURE FacetMatrix4_2
@@ -146,59 +146,59 @@
MODULE PROCEDURE FacetMatrix4_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), taubar( : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), taubar(:), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
!!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- i3 = Eye( nsd )
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mu * taubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips )))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, taubar, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, taubar, i3)
!!
END PROCEDURE FacetMatrix4_3
@@ -208,59 +208,59 @@
MODULE PROCEDURE FacetMatrix4_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), i3( :, : )
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), mubar(:), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, jj, nsd1, nsd2
!!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- i3 = Eye( nsd )
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips )))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, mubar, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, mubar, i3)
!!
END PROCEDURE FacetMatrix4_4
@@ -270,60 +270,60 @@
MODULE PROCEDURE FacetMatrix4_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & G12( :, :, : ), m4( :, :, :, : ), mubar( : ), taubar( : ), i3(:,:)
- INTEGER( I4B ) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & G12(:, :, :), m4(:, :, :, :), mubar(:), taubar(:), i3(:, :)
+INTEGER(I4B) :: ips, ii, nips, nns1, nns2, nsd, nsd1, nsd2, jj
!!
- nns2 = SIZE( elemsd%N, 1 )
- nns1 = SIZE( elemsd%dNdXt, 1 )
- nsd = SIZE( elemsd%dNdXt, 2 )
- nips = SIZE( elemsd%dNdXt, 3 )
- i3 = Eye( nsd )
+nns2 = SIZE(elemsd%N, 1)
+nns1 = SIZE(elemsd%dNdXt, 1)
+nsd = SIZE(elemsd%dNdXt, 2)
+nips = SIZE(elemsd%dNdXt, 3)
+i3 = Eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- CALL Reallocate(G12, nns1, nsd, nsd)
- CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
+CALL Reallocate(G12, nns1, nsd, nsd)
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
!!
- CALL getProjectionOfdNdXt( &
- & obj=elemsd, &
- & cdNdXt=masterC1, &
- & val=elemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=elemsd, &
+ & cdNdXt=masterC1, &
+ & val=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- G12 = OUTERPROD( masterC1( :, ips ), i3 ) &
- & + OUTERPROD( elemsd%dNdXt( :, :, ips ), &
- & elemsd%normal( 1:nsd, ips ) )
+ G12 = OUTERPROD(masterC1(:, ips), i3) &
+ & + OUTERPROD(elemsd%dNdXt(:, :, ips), &
+ & elemsd%normal(1:nsd, ips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval( ips ) * OUTERPROD( &
- & elemsd%N( :, ips ), &
- & MATMUL( &
- & G12( :, :, ii+jj-1 ), elemsd%normal( 1:nsd, ips )))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * OUTERPROD( &
+ & elemsd%N(:, ips), &
+ & MATMUL( &
+ & G12(:, :, ii + jj - 1), elemsd%normal(1:nsd, ips)))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, G12, mubar, taubar, i3 )
+DEALLOCATE (m4, realval, masterC1, G12, mubar, taubar, i3)
!!
END PROCEDURE FacetMatrix4_5
@@ -331,4 +331,4 @@
!
!----------------------------------------------------------------------------
-END SUBMODULE FacetMatrix4Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix4Methods
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90
index ef1f352f7..7d5da6e4f 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix5Methods.F90
@@ -26,81 +26,81 @@
MODULE PROCEDURE FacetMatrix5_1
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & G12( :, :, : ), i3(:,:)
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- !!
- i3 = eye( nsd )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( &
- & G12( nns, nsd, nsd ), &
- & C2( nsd, nns, nips ), &
- & m4( nns, nns, nsd1, nsd2 ))
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- DO ips = 1, nips
- !!
- slaveips = quadMap( ips )
- C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips))
- C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips))
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & G12(:, :, :), i3(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+ !!
+i3 = eye(nsd)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE ( &
+ & G12(nns, nsd, nsd), &
+ & C2(nsd, nns, nips), &
+ & m4(nns, nns, nsd1, nsd2))
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+DO ips = 1, nips
!!
- END DO
+ slaveips = quadMap(ips)
+ C2(:, 1:nns1, ips) = 0.5_DFP * TRANSPOSE(masterElemSD%dNdXt(:, :, ips))
+C2(:, nns1 + 1:, ips) = 0.5_DFP * TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips))
+ !!
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, G12)
!!
END PROCEDURE FacetMatrix5_1
@@ -110,84 +110,84 @@
MODULE PROCEDURE FacetMatrix5_2
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & G12( :, :, : ), i3(:,:)
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & G12(:, :, :), i3(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- ALLOCATE( &
- & G12( nns, nsd, nsd ), &
- & C2( nsd, nns, nips ), &
- & m4( nns, nns, nsd1, nsd2 ))
+ALLOCATE ( &
+ & G12(nns, nsd, nsd), &
+ & C2(nsd, nns, nips), &
+ & m4(nns, nns, nsd1, nsd2))
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- masterC1 = muMaster * masterC1
- slaveC1 = muSlave * slaveC1
+masterC1 = muMaster * masterC1
+slaveC1 = muSlave * slaveC1
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips = quadMap( ips )
- C2(:,1:nns1,ips)=0.5_DFP*TRANSPOSE(masterElemSD%dNdXt(:,:,ips))
- C2(:,nns1+1:,ips)=0.5_DFP*TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips))
+ slaveips = quadMap(ips)
+ C2(:, 1:nns1, ips) = 0.5_DFP * TRANSPOSE(masterElemSD%dNdXt(:, :, ips))
+C2(:, nns1 + 1:, ips) = 0.5_DFP * TRANSPOSE(slaveElemSD%dNdXt(:, :, slaveips))
!!
- END DO
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, G12)
!!
END PROCEDURE FacetMatrix5_2
@@ -197,86 +197,86 @@
MODULE PROCEDURE FacetMatrix5_3
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & G12( :, :, : ), i3(:,:)
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- !!
- i3 = eye( nsd )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( &
- & G12( nns, nsd, nsd ), &
- & C2( nsd, nns, nips ), &
- & m4( nns, nns, nsd1, nsd2 ))
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- masterC1 = muMaster * masterC1
- slaveC1 = muSlave * slaveC1
- !!
- DO ips = 1, nips
- !!
- slaveips = quadMap( ips )
- C2(:,1:nns1,ips)=(0.5_DFP*tauMaster)*TRANSPOSE( &
- & masterElemSD%dNdXt(:,:,ips))
- C2(:,nns1+1:,ips)=(0.5_DFP*tauSlave)*TRANSPOSE( &
- & slaveElemSD%dNdXt(:, :, slaveips))
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & G12(:, :, :), i3(:, :)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+ !!
+i3 = eye(nsd)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE ( &
+ & G12(nns, nsd, nsd), &
+ & C2(nsd, nns, nips), &
+ & m4(nns, nns, nsd1, nsd2))
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+masterC1 = muMaster * masterC1
+slaveC1 = muSlave * slaveC1
+ !!
+DO ips = 1, nips
!!
- END DO
+ slaveips = quadMap(ips)
+ C2(:, 1:nns1, ips) = (0.5_DFP * tauMaster) * TRANSPOSE( &
+ & masterElemSD%dNdXt(:, :, ips))
+ C2(:, nns1 + 1:, ips) = (0.5_DFP * tauSlave) * TRANSPOSE( &
+ & slaveElemSD%dNdXt(:, :, slaveips))
+ !!
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, G12)
!!
END PROCEDURE FacetMatrix5_3
@@ -286,99 +286,99 @@
MODULE PROCEDURE FacetMatrix5_4
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & G12( :, :, : ), i3(:,:), muMasterBar( : ), muSlaveBar( : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- !!
- i3 = eye( nsd )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( &
- & G12( nns, nsd, nsd ), &
- & C2( nsd, nns, nips ), &
- & m4( nns, nns, nsd1, nsd2 ))
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
- !!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
- !!
- DO ips = 1, nips
- masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips )
- slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips )
- END DO
- !!
- DO ips = 1, nips
- !!
- slaveips = quadMap( ips )
- C2(:,1:nns1,ips)=(0.5_DFP)*TRANSPOSE( &
- & masterElemSD%dNdXt(:,:,ips))
- C2(:,nns1+1:,ips)=(0.5_DFP)*TRANSPOSE( &
- & slaveElemSD%dNdXt(:, :, slaveips))
- !!
- END DO
- !!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
- !!
- DO ips = 1, nips
- !!
- slaveips=quadMap(ips)
- !!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
- !!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
- !!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & G12(:, :, :), i3(:, :), muMasterBar(:), muSlaveBar(:)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
+ !!
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+ !!
+i3 = eye(nsd)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE ( &
+ & G12(nns, nsd, nsd), &
+ & C2(nsd, nns, nips), &
+ & m4(nns, nns, nsd1, nsd2))
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=muMasterBar, &
+ & val=muMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=muSlaveBar, &
+ & val=muSlave)
+ !!
+DO ips = 1, nips
+ masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips)
+ slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips)
+END DO
+ !!
+DO ips = 1, nips
+ !!
+ slaveips = quadMap(ips)
+ C2(:, 1:nns1, ips) = (0.5_DFP) * TRANSPOSE( &
+ & masterElemSD%dNdXt(:, :, ips))
+ C2(:, nns1 + 1:, ips) = (0.5_DFP) * TRANSPOSE( &
+ & slaveElemSD%dNdXt(:, :, slaveips))
+ !!
+END DO
+ !!
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+ !!
+DO ips = 1, nips
+ !!
+ slaveips = quadMap(ips)
+ !!
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
+ !!
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
+ !!
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, &
- & muMasterBar, muSlaveBar, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, &
+ & muMasterBar, muSlaveBar, G12)
!!
END PROCEDURE FacetMatrix5_4
@@ -388,99 +388,99 @@
MODULE PROCEDURE FacetMatrix5_5
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & G12(:, :, :), i3(:, :), tauMasterBar(:), tauSlaveBar(:)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
!!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
!!
- i3 = eye( nsd )
+i3 = eye(nsd)
!!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
!!
- ALLOCATE( &
- & G12( nns, nsd, nsd ), &
- & C2( nsd, nns, nips ), &
- & m4( nns, nns, nsd1, nsd2 ))
+ALLOCATE ( &
+ & G12(nns, nsd, nsd), &
+ & C2(nsd, nns, nips), &
+ & m4(nns, nns, nsd1, nsd2))
!!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauMasterBar, &
- & val=tauMaster )
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=tauMasterBar, &
+ & val=tauMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=tauSlaveBar, &
- & val=tauSlave )
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=tauSlaveBar, &
+ & val=tauSlave)
!!
- masterC1 = muMaster * masterC1
- slaveC1 = muSlave * slaveC1
+masterC1 = muMaster * masterC1
+slaveC1 = muSlave * slaveC1
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips = quadMap( ips )
+ slaveips = quadMap(ips)
!!
- C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( &
- & masterElemSD%dNdXt(:,:,ips))
+ C2(:, 1:nns1, ips) = (0.5_DFP * tauMasterBar(ips)) * TRANSPOSE( &
+ & masterElemSD%dNdXt(:, :, ips))
!!
- C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( &
- & slaveElemSD%dNdXt(:, :, slaveips))
+ C2(:, nns1 + 1:, ips) = (0.5_DFP * tauSlaveBar(slaveips)) * TRANSPOSE( &
+ & slaveElemSD%dNdXt(:, :, slaveips))
!!
- END DO
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, &
- & tauMasterBar, tauSlaveBar, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, &
+ & tauMasterBar, tauSlaveBar, G12)
!!
END PROCEDURE FacetMatrix5_5
@@ -490,113 +490,113 @@
MODULE PROCEDURE FacetMatrix5_6
!!
- REAL( DFP ), ALLOCATABLE :: realval( : ), masterC1( :, : ), &
- & slaveC1( :, : ), C2( :, :, : ), m4( :, :, :, : ), &
- & G12( :, :, : ), i3(:,:), tauMasterBar( : ), tauSlaveBar( : ), &
- & muMasterBar( : ), muSlaveBar( : )
- INTEGER( I4B ) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
- & slaveips
- !!
- nns1 = SIZE( masterElemSD%dNdXt, 1 )
- nsd = SIZE( masterElemSD%dNdXt, 2 )
- nips = SIZE( masterElemSD%dNdXt, 3 )
- nns2 = SIZE( slaveElemSD%dNdXt, 1 )
- nns = nns1 + nns2
- !!
- i3 = eye( nsd )
- !!
- IF( opt .EQ. 1 ) THEN
- nsd1 = nsd
- nsd2 = 1
- ELSE
- nsd1 = 1
- nsd2 = nsd
- END IF
- !!
- ALLOCATE( &
- & G12( nns, nsd, nsd ), &
- & C2( nsd, nns, nips ), &
- & m4( nns, nns, nsd1, nsd2 ))
- !!
- CALL getProjectionOfdNdXt( &
- & obj=masterElemsd, &
- & cdNdXt=masterC1, &
- & val=masterElemsd%normal )
- !!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
- !!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
- !!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
- !!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauMasterBar, &
- & val=tauMaster )
- !!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=tauSlaveBar, &
- & val=tauSlave )
- !!
- DO ips = 1, nips
- masterC1(:, ips) = muMasterBar( ips ) * masterC1( :, ips )
- slaveC1(:, ips) = muSlaveBar( ips ) * slaveC1( :, ips )
- END DO
+REAL(DFP), ALLOCATABLE :: realval(:), masterC1(:, :), &
+ & slaveC1(:, :), C2(:, :, :), m4(:, :, :, :), &
+ & G12(:, :, :), i3(:, :), tauMasterBar(:), tauSlaveBar(:), &
+ & muMasterBar(:), muSlaveBar(:)
+INTEGER(I4B) :: ips, nips, nns1, nns2, nsd, nns, nsd1, nsd2, ii, jj, &
+ & slaveips
!!
- DO ips = 1, nips
+nns1 = SIZE(masterElemSD%dNdXt, 1)
+nsd = SIZE(masterElemSD%dNdXt, 2)
+nips = SIZE(masterElemSD%dNdXt, 3)
+nns2 = SIZE(slaveElemSD%dNdXt, 1)
+nns = nns1 + nns2
+ !!
+i3 = eye(nsd)
+ !!
+IF (opt .EQ. 1) THEN
+ nsd1 = nsd
+ nsd2 = 1
+ELSE
+ nsd1 = 1
+ nsd2 = nsd
+END IF
+ !!
+ALLOCATE ( &
+ & G12(nns, nsd, nsd), &
+ & C2(nsd, nns, nips), &
+ & m4(nns, nns, nsd1, nsd2))
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=masterElemsd, &
+ & cdNdXt=masterC1, &
+ & val=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & cdNdXt=slaveC1, &
+ & val=slaveElemsd%normal)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=muMasterBar, &
+ & val=muMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=muSlaveBar, &
+ & val=muSlave)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & interpol=tauMasterBar, &
+ & val=tauMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & interpol=tauSlaveBar, &
+ & val=tauSlave)
+ !!
+DO ips = 1, nips
+ masterC1(:, ips) = muMasterBar(ips) * masterC1(:, ips)
+ slaveC1(:, ips) = muSlaveBar(ips) * slaveC1(:, ips)
+END DO
+ !!
+DO ips = 1, nips
!!
- slaveips = quadMap( ips )
+ slaveips = quadMap(ips)
!!
- C2(:,1:nns1,ips)=(0.5_DFP*tauMasterBar(ips))*TRANSPOSE( &
- & masterElemSD%dNdXt(:,:,ips))
+ C2(:, 1:nns1, ips) = (0.5_DFP * tauMasterBar(ips)) * TRANSPOSE( &
+ & masterElemSD%dNdXt(:, :, ips))
!!
- C2(:,nns1+1:,ips)=(0.5_DFP*tauSlaveBar(slaveips))*TRANSPOSE( &
- & slaveElemSD%dNdXt(:, :, slaveips))
+ C2(:, nns1 + 1:, ips) = (0.5_DFP * tauSlaveBar(slaveips)) * TRANSPOSE( &
+ & slaveElemSD%dNdXt(:, :, slaveips))
!!
- END DO
+END DO
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
!!
- DO ips = 1, nips
+DO ips = 1, nips
!!
- slaveips=quadMap(ips)
+ slaveips = quadMap(ips)
!!
- G12( 1:nns1, :, : ) = OUTERPROD( &
- & masterC1( :, ips ), i3 ) &
- & + OUTERPROD( masterElemSD%dNdXt( :, :, ips ), &
- & masterElemSD%normal( 1:nsd, ips ) )
+ G12(1:nns1, :, :) = OUTERPROD( &
+ & masterC1(:, ips), i3) &
+ & + OUTERPROD(masterElemSD%dNdXt(:, :, ips), &
+ & masterElemSD%normal(1:nsd, ips))
!!
- G12( nns1+1:, :, : ) = OUTERPROD( &
- & slaveC1( :, slaveips ), i3 ) &
- & + OUTERPROD( slaveElemSD%dNdXt( :, :, slaveips ), &
- & slaveElemSD%normal( 1:nsd, slaveips ) )
+ G12(nns1 + 1:, :, :) = OUTERPROD( &
+ & slaveC1(:, slaveips), i3) &
+ & + OUTERPROD(slaveElemSD%dNdXt(:, :, slaveips), &
+ & slaveElemSD%normal(1:nsd, slaveips))
!!
- DO jj = 1, nsd2
- DO ii = 1, nsd1
+ DO jj = 1, nsd2
+ DO ii = 1, nsd1
!!
- m4( :, :, ii, jj ) = m4( :, :, ii, jj ) &
- & + realval(ips)*MATMUL(G12(:,:,ii+jj-1), C2(:, :, ips))
+ m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+ & + realval(ips) * MATMUL(G12(:, :, ii + jj - 1), C2(:, :, ips))
!!
- END DO
END DO
- !!
END DO
+ !!
+END DO
!!
- CALL Convert( from=m4, to=ans )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( realval, masterC1, slaveC1, C2, m4, i3, &
- & tauMasterBar, tauSlaveBar, muMasterBar, muSlaveBar, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, &
+ & tauMasterBar, tauSlaveBar, muMasterBar, muSlaveBar, G12)
!!
END PROCEDURE FacetMatrix5_6
-END SUBMODULE FacetMatrix5Methods
\ No newline at end of file
+END SUBMODULE FacetMatrix5Methods
diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90
index fac9e0eae..cfd0697ba 100644
--- a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90
+++ b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90
@@ -17,6 +17,7 @@
SUBMODULE(ReferenceElement_Method) GeometryMethods
USE ErrorHandling, ONLY: Errormsg
+
USE Display_Method
USE ReferencePoint_Method, ONLY: Measure_Simplex_Point, Point_quality, &
@@ -28,7 +29,8 @@
TotalEntities_Line, &
GetFaceElemType_Line, &
GetEdgeConnectivity_Line, &
- GetFaceConnectivity_Line
+ GetFaceConnectivity_Line, &
+ RefCoord_Line
USE ReferenceTriangle_Method, ONLY: Measure_Simplex_Triangle, &
Triangle_quality, &
@@ -37,7 +39,8 @@
TotalNodesInElement_Triangle, &
TotalEntities_Triangle, &
GetFaceConnectivity_Triangle, &
- GetFaceElemType_Triangle
+ GetFaceElemType_Triangle, &
+ RefCoord_Triangle
USE ReferenceQuadrangle_Method, ONLY: Measure_Simplex_Quadrangle, &
Quadrangle_quality, &
@@ -45,7 +48,8 @@
TotalNodesInElement_Quadrangle, &
TotalEntities_Quadrangle, &
GetFaceConnectivity_Quadrangle, &
- GetFaceElemType_Quadrangle
+ GetFaceElemType_Quadrangle, &
+ RefCoord_Quadrangle
USE ReferenceTetrahedron_Method, ONLY: Measure_Simplex_Tetrahedron, &
Tetrahedron_quality, &
@@ -53,7 +57,8 @@
GetFaceConnectivity_Tetrahedron, &
GetFaceElemType_Tetrahedron, &
TotalNodesInElement_Tetrahedron, &
- TotalEntities_Tetrahedron
+ TotalEntities_Tetrahedron, &
+ RefCoord_Tetrahedron
USE ReferenceHexahedron_Method, ONLY: Measure_Simplex_Hexahedron, &
Hexahedron_quality, &
@@ -61,7 +66,8 @@
GetFaceConnectivity_Hexahedron, &
GetFaceElemType_Hexahedron, &
TotalNodesInElement_Hexahedron, &
- TotalEntities_Hexahedron
+ TotalEntities_Hexahedron, &
+ RefCoord_Hexahedron
USE ReferencePrism_Method, ONLY: Measure_Simplex_Prism, &
Prism_quality, &
@@ -69,7 +75,8 @@
GetFaceConnectivity_Prism, &
GetFaceElemType_Prism, &
TotalNodesInElement_Prism, &
- TotalEntities_Prism
+ TotalEntities_Prism, &
+ RefCoord_Prism
USE ReferencePyramid_Method, ONLY: Measure_Simplex_Pyramid, &
Pyramid_quality, &
@@ -77,11 +84,103 @@
GetFaceConnectivity_Pyramid, &
GetFaceElemType_Pyramid, &
TotalNodesInElement_Pyramid, &
- TotalEntities_Pyramid
+ TotalEntities_Pyramid, &
+ RefCoord_Pyramid
IMPLICIT NONE
CONTAINS
+!----------------------------------------------------------------------------
+! RefCoord
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RefCoord
+INTEGER(I4B) :: topo
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+
+CASE (Point)
+ ALLOCATE (ans(3, 1))
+ ans = 0.0_DFP
+
+CASE (Line)
+ ans = RefCoord_Line(refElem)
+
+CASE (Triangle)
+ ans = RefCoord_Triangle(refElem)
+
+CASE (Quadrangle)
+ ans = RefCoord_Quadrangle(refElem)
+
+CASE (Tetrahedron)
+ ans = RefCoord_Tetrahedron(refElem)
+
+CASE (Hexahedron)
+ ans = RefCoord_Hexahedron(refElem)
+
+CASE (Prism)
+ ans = RefCoord_Prism(refElem)
+
+CASE (Pyramid)
+ ans = RefCoord_Pyramid(refElem)
+END SELECT
+END PROCEDURE RefCoord
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RefCoord_
+INTEGER(I4B) :: topo
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+
+CASE (Point)
+ nrow = 3
+ ncol = 1
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+
+CASE (Line)
+ nrow = 1
+ ncol = 2
+ ans(1:nrow, 1:ncol) = RefCoord_Line(refElem)
+
+CASE (Triangle)
+ nrow = 2
+ ncol = 3
+ ans(1:nrow, 1:ncol) = RefCoord_Triangle(refElem)
+
+CASE (Quadrangle)
+ nrow = 2
+ ncol = 4
+ ans(1:nrow, 1:ncol) = RefCoord_Quadrangle(refElem)
+
+CASE (Tetrahedron)
+ nrow = 3
+ ncol = 4
+ ans(1:nrow, 1:ncol) = RefCoord_Tetrahedron(refElem)
+
+CASE (Hexahedron)
+ nrow = 3
+ ncol = 8
+ ans(1:nrow, 1:ncol) = RefCoord_Hexahedron(refElem)
+
+CASE (Prism)
+ nrow = 3
+ ncol = 6
+ ans(1:nrow, 1:ncol) = RefCoord_Prism(refElem)
+
+CASE (Pyramid)
+ nrow = 3
+ ncol = 5
+ ans(1:nrow, 1:ncol) = RefCoord_Pyramid(refElem)
+END SELECT
+END PROCEDURE RefCoord_
+
!----------------------------------------------------------------------------
! GetElementIndex
!----------------------------------------------------------------------------
@@ -381,38 +480,38 @@
CASE (Line)
- CALL GetFaceElemType_Line(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Line(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
CASE (Triangle)
- CALL GetFaceElemType_Triangle(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Triangle(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
CASE (Quadrangle)
- CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
CASE (Tetrahedron)
- CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
CASE (Hexahedron)
- CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
CASE (Prism)
- CALL GetFaceElemType_Prism(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Prism(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
CASE (Pyramid)
- CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, opt=opt, &
- & tFaceNodes=tFaceNodes, elemType=elemType)
+ CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType)
END SELECT
END PROCEDURE GetFaceElemType1
diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90
index 17ecc9228..f54ae27ec 100644
--- a/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90
+++ b/src/submodules/Geometry/src/ReferenceElement_Method@VTKMethods.F90
@@ -51,7 +51,7 @@
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE get_vtk_elemType
+MODULE PROCEDURE GetVTKElementType1
SELECT CASE (ElemType)
CASE (Point1)
@@ -149,6 +149,132 @@
nptrs = [1, 2, 3, 4, 5, 6, 7, 8, 10, 9, &
12, 11, 13, 14, 16, 15]
END SELECT
-END PROCEDURE get_vtk_elemType
+END PROCEDURE GetVTKElementType1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetVTKElementType1_
+
+SELECT CASE (ElemType)
+CASE (Point1)
+ vtk_type = vtk_point
+ tsize = 1
+ nptrs(1:tsize) = [1]
+
+CASE (Line2)
+ vtk_type = vtk_line2
+ tsize = 2
+ nptrs(1:tsize) = [1, 2]
+
+CASE (Triangle3)
+ vtk_type = vtk_triangle3
+ tsize = 3
+ nptrs(1:tsize) = [1, 2, 3]
+
+CASE (Quadrangle4)
+ vtk_type = vtk_quadrangle4
+ tsize = 4
+ nptrs(1:tsize) = [1, 2, 3, 4]
+
+CASE (Tetrahedron4)
+ vtk_type = vtk_Tetrahedron4
+ tsize = 4
+ nptrs(1:tsize) = [1, 2, 3, 4]
+
+CASE (Hexahedron8)
+ vtk_type = vtk_Hexahedron8
+ tsize = 8
+ nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8]
+
+CASE (Prism6)
+ vtk_type = vtk_Prism6
+ tsize = 6
+ nptrs(1:tsize) = [1, 2, 3, 4, 5, 6]
+
+CASE (Pyramid5)
+ vtk_type = vtk_Pyramid5
+ tsize = 5
+ nptrs(1:tsize) = [1, 2, 3, 4, 5]
+
+ !! Order=2 elements
+CASE (Line3)
+ vtk_type = vtk_line3
+ tsize = 3
+ nptrs(1:tsize) = [1, 2, 3]
+
+CASE (Triangle6)
+ vtk_type = vtk_Triangle6
+ tsize = 6
+ nptrs(1:tsize) = [1, 2, 3, 4, 5, 6]
+
+CASE (Quadrangle9)
+ vtk_type = vtk_Quadrangle9
+ tsize = 9
+ nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8, 9]
+
+CASE (Quadrangle8)
+ vtk_type = vtk_Quadrangle8
+ tsize = 8
+ nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8]
+
+CASE (Tetrahedron10)
+ vtk_type = vtk_Tetrahedron10
+ tsize = 10
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, 6, 7, 9, 8]
+
+CASE (Hexahedron20)
+ vtk_type = vtk_Hexahedron20
+ tsize = 20
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, 6, 7, &
+ 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14]
+
+CASE (Hexahedron27)
+ vtk_type = vtk_Hexahedron27
+ tsize = 27
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, 6, 7, &
+ 8, 11, 16, 9, 17, 10, 18, 19, 12, 15, 13, 14, &
+ 24, 22, 20, 21, 23, 25, 26]
+
+CASE (Prism15)
+ vtk_type = vtk_Prism15
+ tsize = 15
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, &
+ 6, 8, 12, 7, 13, 14, 9, 11, 10]
+
+CASE (Prism18)
+ vtk_type = vtk_Prism18
+ tsize = 18
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, &
+ 6, 8, 12, 7, 13, 14, 9, 11, 10, &
+ 15, 17, 16]
+
+CASE (Pyramid13)
+ vtk_type = vtk_Pyramid13
+ tsize = 13
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, &
+ 5, 8, 9, 6, 10, 7, 11, 12]
+
+CASE (Pyramid14)
+ vtk_type = vtk_Pyramid13
+ tsize = 14
+ nptrs(1:tsize) = 1 + [0, 1, 2, 3, 4, 5, &
+ 5, 8, 9, 6, 10, 7, 11, 12]
+
+ !! order=3 element
+CASE (Line4)
+ vtk_type = vtk_line4
+ tsize = 4
+ nptrs(1:tsize) = [1, 2, 3, 4]
+
+CASE (Quadrangle16)
+ vtk_type = vtk_Quadrangle16
+ tsize = 16
+ nptrs(1:tsize) = [1, 2, 3, 4, 5, 6, 7, 8, 10, 9, &
+ 12, 11, 13, 14, 16, 15]
+END SELECT
+
+END PROCEDURE GetVTKElementType1_
END SUBMODULE VTKMethods
diff --git a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90
index 82e3b9346..fadad220e 100644
--- a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90
+++ b/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90
@@ -504,25 +504,26 @@
MODULE PROCEDURE RefHexahedronCoord
REAL(DFP) :: one, mone
-CHARACTER(:), ALLOCATABLE :: astr
+CHARACTER(1), ALLOCATABLE :: astr
-astr = UpperCase(refHexahedron)
+astr = refHexahedron(1:1)
SELECT CASE (astr)
-CASE ("UNIT")
+CASE ("U", "u")
one = 1.0_DFP
mone = 0.0_DFP
-CASE ("BIUNIT")
+
+CASE ("B", "b")
one = 1.0_DFP
mone = -1.0_DFP
-END SELECT
-astr = ""
+END SELECT
ans(3, 1:4) = mone
ans(3, 5:8) = one
ans(1:2, 1:4) = RefQuadrangleCoord(refHexahedron)
ans(1:2, 5:8) = ans(1:2, 1:4)
+
END PROCEDURE RefHexahedronCoord
!----------------------------------------------------------------------------
diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90
index 918998090..b6805ae2e 100644
--- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90
+++ b/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90
@@ -20,15 +20,29 @@
! summary: This submodule contains methods for [[ReferenceLine_]]
SUBMODULE(ReferenceLine_Method) Methods
-USE ReallocateUtility
-USE ReferenceElement_Method
-USE StringUtility
-USE ApproxUtility
+
+USE GlobalData, ONLY: Line, Line1, Line2, Line3, Line4, Line5, &
+ Line6, Point1, Equidistance
+
+USE ReallocateUtility, ONLY: Reallocate
+
+USE ReferenceElement_Method, ONLY: ReferenceTopology, &
+ ElementType, DEALLOCATE
+
+USE StringUtility, ONLY: UpperCase
+
+USE ApproxUtility, ONLY: OPERATOR(.approxeq.)
+
USE String_Class, ONLY: String
-USE LineInterpolationUtility
-USE Display_Method
-USE InputUtility
+
+USE LineInterpolationUtility, ONLY: InterpolationPoint_Line
+
+USE Display_Method, ONLY: ToString
+
+USE InputUtility, ONLY: Input
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -61,11 +75,11 @@
MODULE PROCEDURE FacetTopology_Line
ans(1)%nptrs = nptrs([1])
ans(1)%xiDimension = 0
-ans(1)%name = Point
+ans(1)%name = Point1
ans(2)%nptrs = nptrs([2])
ans(2)%xiDimension = 0
-ans(2)%name = Point
+ans(2)%name = Point1
END PROCEDURE FacetTopology_Line
!----------------------------------------------------------------------------
@@ -83,7 +97,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE TotalNodesInElement_Line
-SELECT CASE (ElemType)
+SELECT CASE (elemType)
CASE (Line1)
ans = 1
CASE (Line2)
@@ -129,7 +143,7 @@
MODULE PROCEDURE ElementType_Line
SELECT CASE (elemName)
CASE ("Line1", "Point", "Point1")
- ans = Point
+ ans = Point1
CASE ("Line2", "Line")
ans = Line2
CASE ("Line3")
@@ -159,12 +173,12 @@
ans(ii)%xij(1:3, 1) = DEFAULT_REF_LINE_COORD(1:3, ii)
ans(ii)%entityCounts = [1, 0, 0, 0]
ans(ii)%xiDimension = 0
- ans(ii)%name = Point
+ ans(ii)%name = Point1
ans(ii)%interpolationPointType = refelem%interpolationPointType
ans(ii)%order = 0
ans(ii)%nsd = refelem%nsd
ALLOCATE (ans(ii)%topology(1))
- ans(ii)%topology(1) = Referencetopology(nptrs=nptrs, name=Point)
+ ans(ii)%topology(1) = Referencetopology(nptrs=nptrs, name=Point1)
ans(ii)%highOrderElement => NULL()
END DO
END PROCEDURE FacetElements_Line1
@@ -181,12 +195,12 @@
ans(ii)%xij = RESHAPE(DEFAULT_REF_LINE_COORD(1:3, ii), [3, 1])
ans(ii)%entityCounts = [1, 0, 0, 0]
ans(ii)%xiDimension = 0
- ans(ii)%name = Point
+ ans(ii)%name = Point1
ans(ii)%interpolationPointType = Equidistance
ans(ii)%order = 0
ans(ii)%nsd = nsd
ALLOCATE (ans(ii)%topology(1))
- ans(ii)%topology(1) = Referencetopology(nptrs=nptrs(ii:ii), name=Point)
+ ans(ii)%topology(1) = Referencetopology(nptrs=nptrs(ii:ii), name=Point1)
ans(ii)%highOrderElement => NULL()
END DO
END PROCEDURE FacetElements_Line2
@@ -251,8 +265,8 @@
obj%nsd = nsd
obj%name = Line2
ALLOCATE (obj%topology(3))
-obj%topology(1) = ReferenceTopology([1], Point)
-obj%topology(2) = ReferenceTopology([2], Point)
+obj%topology(1) = ReferenceTopology([1], Point1)
+obj%topology(2) = ReferenceTopology([2], Point1)
obj%topology(3) = ReferenceTopology([1, 2], Line2)
obj%highorderElement => highorderElement_Line
END PROCEDURE Initiate_ref_Line
@@ -262,7 +276,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reference_Line
-CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName)
+CALL Initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName)
END PROCEDURE Reference_Line
!----------------------------------------------------------------------------
@@ -271,7 +285,7 @@
MODULE PROCEDURE Reference_Line_Pointer_1
ALLOCATE (obj)
-CALL initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName)
+CALL Initiate_ref_line(obj=obj, nsd=nsd, xij=xij, domainName=domainName)
END PROCEDURE Reference_Line_Pointer_1
!----------------------------------------------------------------------------
@@ -280,11 +294,13 @@
MODULE PROCEDURE HighorderElement_Line
INTEGER(I4B) :: nns, i
+
obj%xij = InterpolationPoint_Line( &
- & xij=refelem%xij, &
- & order=order, &
- & ipType=ipType, &
- & layout="VEFC")
+ xij=refelem%xij, &
+ order=order, &
+ ipType=ipType, &
+ layout="VEFC")
+
obj%domainName = refelem%domainName
obj%nsd = refelem%nsd
nns = SIZE(obj%xij, 2)
@@ -294,7 +310,7 @@
obj%name = ElementType("Line"//ToString(nns))
ALLOCATE (obj%topology(nns + 1))
DO CONCURRENT(i=1:nns)
- obj%topology(i) = ReferenceTopology([i], Point)
+ obj%topology(i) = ReferenceTopology([i], Point1)
END DO
obj%topology(nns + 1) = ReferenceTopology([(i, i=1, nns)], obj%name)
END PROCEDURE HighorderElement_Line
@@ -330,13 +346,14 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE RefLineCoord
-TYPE(String) :: astr
-astr = UpperCase(refLine)
-SELECT CASE (astr%chars())
-CASE ("UNIT")
- ans(1, :) = [0.0_DFP, 1.0_DFP]
-CASE ("BIUNIT")
- ans(1, :) = [-1.0_DFP, 1.0_DFP]
+CHARACTER(1) :: astr
+
+astr = refline(1:1)
+SELECT CASE (astr)
+CASE ("U", "u")
+ ans(1, 1:2) = [0.0_DFP, 1.0_DFP]
+CASE ("B", "b")
+ ans(1, 1:2) = [-1.0_DFP, 1.0_DFP]
END SELECT
END PROCEDURE RefLineCoord
diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90
index 76b697b41..b7f438a7f 100644
--- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90
+++ b/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90
@@ -20,23 +20,40 @@
! summary: This submodule contains method for [[ReferenceQuadrangle_]]
SUBMODULE(ReferenceQuadrangle_Method) Methods
-USE ReferenceElement_Method
+
+USE GlobalData, ONLY: Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, &
+ Quadrangle16, Point, Line2, Equidistance, INT8
+
+USE ReferenceElement_Method, ONLY: ReferenceTopology, DEALLOCATE, &
+ ReferenceElement_Initiate => Initiate
+
USE LineInterpolationUtility, ONLY: InterpolationPoint_Line
-USE ReferenceLine_Method, ONLY: ElementOrder_Line, ElementName_Line
-USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle, &
- & LagrangeDOF_Quadrangle
+USE ReferenceLine_Method, ONLY: ElementOrder_Line, LineName
+
+USE QuadrangleInterpolationUtility, ONLY: InterpolationPoint_Quadrangle, &
+ LagrangeDOF_Quadrangle
+
USE ReferenceTriangle_Method, ONLY: TRIANGLEAREA2D
+
USE ReferenceLine_Method, ONLY: Linename, ElementType_Line
-USE ApproxUtility
+USE ApproxUtility, ONLY: OPERATOR(.approxeq.)
+
USE AppendUtility
-USE StringUtility
-USE ArangeUtility
-USE InputUtility
-USE SortUtility
-USE ReallocateUtility
-USE Display_Method
+
+USE StringUtility, ONLY: UpperCase
+
+USE ArangeUtility, ONLY: Arange
+
+USE InputUtility, ONLY: Input
+
+USE SortUtility, ONLY: Sort
+
+USE ReallocateUtility, ONLY: Reallocate
+
+USE Display_Method, ONLY: ToString
+
USE MiscUtility, ONLY: Int2Str
IMPLICIT NONE
@@ -71,8 +88,8 @@
order = ElementOrder_Quadrangle(elemType)
CALL Reallocate(con, order + 1, 4)
-CALL GetEdgeConnectivity_Quadrangle(con=con, &
- & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order)
+CALL GetEdgeConnectivity_Quadrangle(con=con, &
+ opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order)
lineType = ElementType_Line("Line"//Int2Str(order + 1))
DO ii = 1, 4
@@ -99,7 +116,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE TotalNodesInElement_Quadrangle
-SELECT CASE (ElemType)
+SELECT CASE (elemType)
CASE (Quadrangle4)
ans = 4
CASE (Quadrangle8)
@@ -118,7 +135,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE ElementOrder_Quadrangle
-SELECT CASE (ElemType)
+SELECT CASE (elemType)
CASE (Quadrangle4)
ans = 1
CASE (Quadrangle8)
@@ -159,10 +176,10 @@
istart = refelem%entityCounts(1)
-ans(1)%xij = InterpolationPoint_Line( &
- & order=refelem%order, &
- & ipType=refelem%interpolationPointType, &
- & layout="VEFC")
+ans(1)%xij = InterpolationPoint_Line( &
+ order=refelem%order, &
+ ipType=refelem%interpolationPointType, &
+ layout="VEFC")
ans(1)%interpolationPointType = refelem%interpolationPointType
ans(1)%nsd = refelem%nsd
@@ -205,8 +222,8 @@
order = ElementOrder_Quadrangle(elemType)
CALL Reallocate(edgeCon, order + 1, 4)
-CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, &
- & opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order)
+CALL GetEdgeConnectivity_Quadrangle(con=edgeCon, &
+ opt=DEFAULT_OPT_QUADRANGLE_EDGE_CON, order=order)
!! The edges are accordign to gmsh
!! [1,2], [2,3], [3,4], [4,1]
@@ -216,22 +233,20 @@
ans(ii)%order = order
ans(ii)%name = ElementType_Line("Line"//tostring(order + 1))
ans(ii)%interpolationPointType = Equidistance
- ans(ii)%xij = InterpolationPoint_Line( &
- & order=order, &
- & ipType=Equidistance, &
- & layout="VEFC")
+ ans(ii)%xij = InterpolationPoint_Line(order=order, ipType=Equidistance, &
+ layout="VEFC")
ans(ii)%nsd = nsd
ans(ii)%entityCounts = [order + 1, 1, 0, 0]
ALLOCATE (ans(ii)%topology(order + 2))
DO jj = 1, order + 1
- ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), &
- & name=Point)
+ ans(ii)%topology(jj) = Referencetopology(nptrs=edgeCon(jj:jj, ii), &
+ name=Point)
END DO
- ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), &
- & name=ans(ii)%name)
+ ans(ii)%topology(order + 2) = Referencetopology(nptrs=edgeCon(1:2, ii), &
+ name=ans(ii)%name)
END DO
@@ -337,13 +352,10 @@
CALL DEALLOCATE (obj)
SELECT CASE (order)
CASE (1)
- CALL Initiate(obj=obj, Anotherobj=refelem)
+ CALL ReferenceElement_Initiate(obj=obj, Anotherobj=refelem)
CASE DEFAULT
- obj%xij = InterpolationPoint_Quadrangle( &
- & xij=refelem%xij, &
- & order=order, &
- & ipType=ipType, &
- & layout="VEFC")
+ obj%xij = InterpolationPoint_Quadrangle(xij=refelem%xij, order=order, &
+ ipType=ipType, layout="VEFC")
obj%domainName = refelem%domainName
NNS = LagrangeDOF_Quadrangle(order=order)
obj%entityCounts = [NNS, 4, 1, 0]
@@ -543,17 +555,18 @@ END SUBROUTINE PARALLELOGRAMAREA2D
!----------------------------------------------------------------------------
MODULE PROCEDURE RefQuadrangleCoord
-CHARACTER(:), ALLOCATABLE :: astr
-astr = UpperCase(refQuadrangle)
+CHARACTER(1) :: astr
+astr = refQuadrangle(1:1)
+
SELECT CASE (astr)
-CASE ("UNIT")
- ans(1, :) = [0.0_DFP, 1.0_DFP, 1.0_DFP, 0.0_DFP]
- ans(2, :) = [0.0_DFP, 0.0_DFP, 1.0_DFP, 1.0_DFP]
-CASE ("BIUNIT")
- ans(1, :) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, -1.0_DFP]
- ans(2, :) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP]
+CASE ("U", "u")
+ ans(1, 1:4) = [0.0_DFP, 1.0_DFP, 1.0_DFP, 0.0_DFP]
+ ans(2, 1:4) = [0.0_DFP, 0.0_DFP, 1.0_DFP, 1.0_DFP]
+
+CASE ("B", "b")
+ ans(1, 1:4) = [-1.0_DFP, 1.0_DFP, 1.0_DFP, -1.0_DFP]
+ ans(2, 1:4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP, 1.0_DFP]
END SELECT
-astr = ""
END PROCEDURE RefQuadrangleCoord
!----------------------------------------------------------------------------
@@ -653,7 +666,7 @@ END SUBROUTINE PARALLELOGRAMAREA2D
MODULE PROCEDURE GetFaceElemType_Quadrangle
INTEGER(I4B) :: order
order = ElementOrder_Quadrangle(Input(default=Quadrangle, option=elemType))
-IF (PRESENT(faceElemType)) faceElemType(1:4) = ElementName_Line(order)
+IF (PRESENT(faceElemType)) faceElemType(1:4) = LineName(order)
IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = order + 1
END PROCEDURE GetFaceElemType_Quadrangle
diff --git a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90
index 1e84e2ad5..9073009d2 100644
--- a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90
+++ b/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90
@@ -489,21 +489,24 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE RefCoord_Tetrahedron
-CHARACTER(:), ALLOCATABLE :: layout
-layout = UpperCase(refTetrahedron)
+CHARACTER(1) :: layout
+
+layout = refTetrahedron(1:1)
+
SELECT CASE (layout)
-CASE ("BIUNIT")
- ans(:, 1) = [-1.0_DFP, -1.0_DFP, -1.0_DFP]
- ans(:, 2) = [1.0_DFP, -1.0_DFP, -1.0_DFP]
- ans(:, 3) = [-1.0_DFP, 1.0_DFP, -1.0_DFP]
- ans(:, 4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP]
-CASE ("UNIT")
- ans(:, 1) = [0.0_DFP, 0.0_DFP, 0.0_DFP]
- ans(:, 2) = [1.0_DFP, 0.0_DFP, 0.0_DFP]
- ans(:, 3) = [0.0_DFP, 1.0_DFP, 0.0_DFP]
- ans(:, 4) = [0.0_DFP, 0.0_DFP, 1.0_DFP]
+CASE ("B", "b")
+ ans(1:3, 1) = [-1.0_DFP, -1.0_DFP, -1.0_DFP]
+ ans(1:3, 2) = [1.0_DFP, -1.0_DFP, -1.0_DFP]
+ ans(1:3, 3) = [-1.0_DFP, 1.0_DFP, -1.0_DFP]
+ ans(1:3, 4) = [-1.0_DFP, -1.0_DFP, 1.0_DFP]
+
+CASE ("U", "u")
+ ans(1:3, 1) = [0.0_DFP, 0.0_DFP, 0.0_DFP]
+ ans(1:3, 2) = [1.0_DFP, 0.0_DFP, 0.0_DFP]
+ ans(1:3, 3) = [0.0_DFP, 1.0_DFP, 0.0_DFP]
+ ans(1:3, 4) = [0.0_DFP, 0.0_DFP, 1.0_DFP]
+
END SELECT
-layout = ""
END PROCEDURE RefCoord_Tetrahedron
!----------------------------------------------------------------------------
diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90
index c1bfa8f99..11712ee97 100644
--- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90
+++ b/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90
@@ -740,19 +740,21 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE RefTriangleCoord
-CHARACTER(:), ALLOCATABLE :: layout
-layout = UpperCase(refTriangle)
-SELECT CASE (layout)
-CASE ("BIUNIT")
- ans(:, 1) = [-1.0_DFP, -1.0_DFP]
- ans(:, 2) = [1.0_DFP, -1.0_DFP]
- ans(:, 3) = [-1.0_DFP, 1.0_DFP]
-CASE ("UNIT")
- ans(:, 1) = [0.0_DFP, 0.0_DFP]
- ans(:, 2) = [1.0_DFP, 0.0_DFP]
- ans(:, 3) = [0.0_DFP, 1.0_DFP]
+CHARACTER(1) :: astr
+
+astr = reftriangle(1:1)
+
+SELECT CASE (astr)
+CASE ("B", "b")
+ ans(1:2, 1) = [-1.0_DFP, -1.0_DFP]
+ ans(1:2, 2) = [1.0_DFP, -1.0_DFP]
+ ans(1:2, 3) = [-1.0_DFP, 1.0_DFP]
+
+CASE ("U", "u")
+ ans(1:2, 1) = [0.0_DFP, 0.0_DFP]
+ ans(1:2, 2) = [1.0_DFP, 0.0_DFP]
+ ans(1:2, 3) = [0.0_DFP, 1.0_DFP]
END SELECT
-layout = ""
END PROCEDURE RefTriangleCoord
!----------------------------------------------------------------------------
diff --git a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90
index 48e791fee..cab95a6a9 100644
--- a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90
+++ b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90
@@ -30,8 +30,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_1
-IF (ALLOCATED(obj%Val)) THEN
- Val = IntVector(obj%Val)
+IF (ALLOCATED(obj%val)) THEN
+ val = IntVector(obj%val)
END IF
END PROCEDURE intVec_get_1
@@ -40,8 +40,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_2
-IF (ALLOCATED(obj%Val)) THEN
- Val = IntVector(obj%Val(Indx))
+IF (ALLOCATED(obj%val)) THEN
+ val = IntVector(obj%val(Indx))
END IF
END PROCEDURE intVec_get_2
@@ -50,8 +50,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_3
-IF (ALLOCATED(obj%Val)) THEN
- Val = IntVector(obj%Val( &
+IF (ALLOCATED(obj%val)) THEN
+ val = IntVector(obj%val( &
& istart:&
& Input(default=SIZE(obj), option=iend):&
& Input(option=stride, default=1)))
@@ -63,7 +63,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_4
-Val = IntVector(get(obj, TypeInt))
+val = IntVector(get(obj, TypeInt))
END PROCEDURE intVec_get_4
!----------------------------------------------------------------------------
@@ -71,7 +71,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_5
-Val = IntVector(get(obj, Indx, TypeInt))
+val = IntVector(get(obj, Indx, TypeInt))
END PROCEDURE intVec_get_5
!----------------------------------------------------------------------------
@@ -79,7 +79,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_6
-Val = IntVector(get(obj, iStart, iEnd, Stride, &
+val = IntVector(get(obj, iStart, iEnd, Stride, &
& TypeInt))
END PROCEDURE intVec_get_6
@@ -88,23 +88,23 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_7a
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val
END IF
END PROCEDURE intVec_get_7a
MODULE PROCEDURE intVec_get_7b
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val
END IF
END PROCEDURE intVec_get_7b
MODULE PROCEDURE intVec_get_7c
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val
END IF
END PROCEDURE intVec_get_7c
MODULE PROCEDURE intVec_get_7d
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val
END IF
END PROCEDURE intVec_get_7d
@@ -113,26 +113,26 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_8a
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(Indx)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(Indx)
END IF
END PROCEDURE intVec_get_8a
MODULE PROCEDURE intVec_get_8b
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(Indx)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(Indx)
END IF
END PROCEDURE intVec_get_8b
MODULE PROCEDURE intVec_get_8c
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(Indx)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(Indx)
END IF
END PROCEDURE intVec_get_8c
MODULE PROCEDURE intVec_get_8d
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(Indx)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(Indx)
END IF
END PROCEDURE intVec_get_8d
@@ -141,26 +141,26 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_9a
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(iStart:iEnd:Stride)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(iStart:iEnd:Stride)
END IF
END PROCEDURE intVec_get_9a
MODULE PROCEDURE intVec_get_9b
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(iStart:iEnd:Stride)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(iStart:iEnd:Stride)
END IF
END PROCEDURE intVec_get_9b
MODULE PROCEDURE intVec_get_9c
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(iStart:iEnd:Stride)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(iStart:iEnd:Stride)
END IF
END PROCEDURE intVec_get_9c
MODULE PROCEDURE intVec_get_9d
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val(iStart:iEnd:Stride)
+IF (ALLOCATED(obj%val)) THEN
+ val = obj%val(iStart:iEnd:Stride)
END IF
END PROCEDURE intVec_get_9d
@@ -237,7 +237,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_getPointer_1
-Val => obj
+val => obj
END PROCEDURE intVec_getPointer_1
!----------------------------------------------------------------------------
@@ -245,7 +245,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_getPointer_2
-Val => obj%Val
+val => obj%val
END PROCEDURE intVec_getPointer_2
!----------------------------------------------------------------------------
@@ -253,7 +253,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_getIndex1
-Ans = MINLOC(ABS(obj%Val - val), 1)
+ans = MINLOC(ABS(obj%val - val), 1)
END PROCEDURE intVec_getIndex1
!----------------------------------------------------------------------------
@@ -262,19 +262,19 @@
MODULE PROCEDURE intVec_getIndex2
INTEGER(I4B) :: i, j, m
-LOGICAL(LGT), ALLOCATABLE :: Search(:)
+LOGICAL(LGT), ALLOCATABLE :: search(:)
!
m = SIZE(val)
-ALLOCATE (Search(m), Ans(m))
-Search = .TRUE.
-Ans = 0
+ALLOCATE (search(m), ans(m))
+search = .TRUE.
+ans = 0
-DO i = 1, SIZE(obj%Val)
+DO i = 1, SIZE(obj%val)
DO j = 1, m
- IF (Search(j)) THEN
- IF (val(j) .EQ. obj%Val(i)) THEN
- Search(j) = .FALSE.
- Ans(j) = i
+ IF (search(j)) THEN
+ IF (val(j) .EQ. obj%val(i)) THEN
+ search(j) = .FALSE.
+ ans(j) = i
END IF
END IF
END DO
diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90
index 880619fef..009ca1ada 100644
--- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90
+++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90
@@ -196,6 +196,36 @@ END SUBROUTINE MM_2d
DEALLOCATE (realval)
END PROCEDURE MassMatrix_1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Massmatrix1_
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+REAL(DFP) :: realval
+INTEGER(I4B) :: ii, jj, ips
+
+nrow = test%nns
+ncol = trial%nns
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ips = 1, trial%nips
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=ii, ncol=jj, ans=ans, scale=realval, anscoeff=one)
+
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE Massmatrix1_
+
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
@@ -218,6 +248,37 @@ END SUBROUTINE MM_2d
DEALLOCATE (realval)
END PROCEDURE MassMatrix_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix2_
+REAL(DFP) :: realval(trial%nips)
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+INTEGER(I4B) :: ips, ii, jj
+
+nrow = test%nns
+ncol = trial%nns
+realval = 0.0_DFP
+CALL GetInterpolation_(obj=trial, interpol=realval, &
+ val=rho, tsize=ii)
+realval = trial%js * trial%ws * trial%thickness * realval
+
+DO ips = 1, SIZE(realval)
+ CALL OuterProd_(a=test%N(1:nrow, ips), &
+ b=trial%N(1:ncol, ips), &
+ nrow=ii, ncol=jj, ans=ans, scale=realval(ips), &
+ anscoeff=one)
+END DO
+
+IF (PRESENT(opt)) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt, nrow=nrow, ncol=ncol)
+ nrow = opt * nrow
+ ncol = opt * ncol
+END IF
+
+END PROCEDURE MassMatrix2_
+
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
@@ -235,6 +296,14 @@ END SUBROUTINE MM_2d
END SELECT
END PROCEDURE MassMatrix_3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE massmatrix3_
+! TODO: implement
+END PROCEDURE massmatrix3_
+
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
@@ -267,6 +336,14 @@ END SUBROUTINE MM_2d
DEALLOCATE (realval, m2, kbar, m4)
END PROCEDURE MassMatrix_4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix4_
+! TODO: implement
+END PROCEDURE MassMatrix4_
+
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
@@ -292,7 +369,7 @@ END SUBROUTINE MM_2d
bcoeff = SQRT(rhoBar * muBar)
acoeff = SQRT(rhoBar * (lambdaBar + 2.0_DFP * muBar)) - bcoeff
-nsd = trial%refelem%nsd
+nsd = trial%nsd
eyemat = Eye(nsd, 1.0_DFP)
nns = SIZE(test%N, 1)
ALLOCATE (m4(nns, nns, nsd, nsd))
diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt
index 90b4a65e5..8cdab8754 100644
--- a/src/submodules/Polynomial/CMakeLists.txt
+++ b/src/submodules/Polynomial/CMakeLists.txt
@@ -33,6 +33,7 @@ target_sources(
${src_path}/PyramidInterpolationUtility@Methods.F90
${src_path}/InterpolationUtility@Methods.F90
${src_path}/LagrangePolynomialUtility@Methods.F90
+ ${src_path}/HierarchicalPolynomialUtility@Methods.F90
${src_path}/JacobiPolynomialUtility@Methods.F90
${src_path}/UltrasphericalPolynomialUtility@Methods.F90
${src_path}/LegendrePolynomialUtility@Methods.F90
diff --git a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90
index 8c905ad17..a2c5ab5ab 100644
--- a/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/Chebyshev1PolynomialUtility@Methods.F90
@@ -16,8 +16,28 @@
!
SUBMODULE(Chebyshev1PolynomialUtility) Methods
-USE BaseMethod
+USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix
+
+#ifdef USE_LAPACK95
+USE F95_Lapack, ONLY: STEV
+#endif
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE MiscUtility, ONLY: Factorial
+
+USE BaseType, ONLY: qp => TypeQuadratureOpt
+
+USE GlobalData, ONLY: pi
+
+USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalDMatEvenOdd
+
+USE JacobiPolynomialUtility, ONLY: JacobiJacobiMatrix, &
+ JacobiJacobiRadauMatrix, &
+ JacobiJacobiLobattoMatrix
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -243,12 +263,12 @@
END IF
!!
SELECT CASE (QuadType)
-CASE (Gauss)
+CASE (qp%Gauss)
!!
order = n
CALL Chebyshev1GaussQuadrature(n=order, pt=pt, wt=wt)
!!
-CASE (GaussRadau, GaussRadauLeft)
+CASE (qp%GaussRadau, qp%GaussRadauLeft)
!!
IF (inside) THEN
order = n
@@ -261,7 +281,7 @@
CALL Chebyshev1GaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt)
END IF
!!
-CASE (GaussRadauRight)
+CASE (qp%GaussRadauRight)
!!
IF (inside) THEN
order = n
@@ -273,7 +293,7 @@
CALL Chebyshev1GaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt)
END IF
!!
-CASE (GaussLobatto)
+CASE (qp%GaussLobatto)
!!
IF (inside) THEN
order = n
@@ -357,54 +377,68 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Chebyshev1EvalAll1
+INTEGER(I4B) :: tsize
+CALL Chebyshev1EvalAll1_(tsize=tsize, ans=ans, n=n, x=x)
+END PROCEDURE Chebyshev1EvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Chebyshev1EvalAll1_
INTEGER(I4B) :: i
-!!
-ans = 0.0_DFP
-!!
-IF (n < 0) THEN
- RETURN
-END IF
-!!
+
+tsize = 0
+
+IF (n < 0) RETURN
+
+tsize = n + 1
ans(1) = 1.0_DFP
-!!
-IF (n .EQ. 0) THEN
- RETURN
-END IF
-!!
+
+IF (n .EQ. 0) RETURN
+
ans(2) = x
-!!
+
DO i = 2, n
ans(i + 1) = (2.0_DFP * x) * ans(i) - ans(i - 1)
END DO
-!!
-END PROCEDURE Chebyshev1EvalAll1
+END PROCEDURE Chebyshev1EvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE Chebyshev1EvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL Chebyshev1EvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE Chebyshev1EvalAll2
+
+!----------------------------------------------------------------------------
+! Chebyshev1EvalAll_
+!----------------------------------------------------------------------------
+
+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
-!!
+
+nrow = 0
+ncol = 0
+
+IF (n < 0) RETURN
+
+nrow = SIZE(x)
+ncol = n + 1
+
+ans(1:nrow, 1) = 1.0_DFP
+
+IF (n .EQ. 0) RETURN
+
+ans(1:nrow, 2) = x
+
DO i = 2, n
- ans(:, i + 1) = (2.0_DFP * x) * ans(:, i) - ans(:, i - 1)
+ ans(1:nrow, i + 1) = (2.0_DFP * x) * ans(1:nrow, i) - ans(1:nrow, i - 1)
END DO
-!!
-END PROCEDURE Chebyshev1EvalAll2
+
+END PROCEDURE Chebyshev1EvalAll2_
!----------------------------------------------------------------------------
! Chebyshev1MonomialExpansionAll
@@ -460,82 +494,96 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Chebyshev1GradientEvalAll1
-!!
+INTEGER(I4B) :: tsize
+CALL Chebyshev1GradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE Chebyshev1GradientEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Chebyshev1GradientEvalAll1_
INTEGER(I4B) :: ii
REAL(DFP) :: p(1:n + 1), r_ii
-!!
-IF (n < 0) THEN
- RETURN
-END IF
-!!
+
+tsize = 0
+IF (n < 0) RETURN
+
+tsize = n + 1
p(1) = 1.0_DFP
ans(1) = 0.0_DFP
-!!
-IF (n < 1) THEN
- RETURN
-END IF
-!!
-IF (n .EQ. 0_I4B) RETURN
-!!
+
+IF (n < 1) 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
+
+END PROCEDURE Chebyshev1GradientEvalAll1_
!----------------------------------------------------------------------------
! Chebyshev1GradientEvalAll2
!----------------------------------------------------------------------------
MODULE PROCEDURE Chebyshev1GradientEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL Chebyshev1GradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE 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
-!!
+
+nrow = 0; ncol = 0
+
+IF (n < 0) RETURN
+
+nrow = SIZE(x)
+ncol = n + 1
+
+p(1:nrow, 1) = 1.0_DFP
+ans(1:nrow, 1) = 0.0_DFP
+
+IF (n < 1) RETURN
+
+p(1:nrow, 2) = x
+ans(1:nrow, 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
-!!
+
+p(1:nrow, 3) = 2.0_DFP * x**2 - 1.0_DFP
+ans(1:nrow, 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)
- !!
+ p(1:nrow, ii + 1) = (2.0_DFP * x) * p(1:nrow, ii) - p(1:nrow, ii - 1)
+
+ ans(1:nrow, ii + 1) = 2.0_DFP * r_ii * p(1:nrow, ii) &
+ + r_ii * ans(1:nrow, ii - 1) / (r_ii - 2.0_DFP)
+
END DO
-!!
-END PROCEDURE Chebyshev1GradientEvalAll2
+
+END PROCEDURE Chebyshev1GradientEvalAll2_
!----------------------------------------------------------------------------
! Chebyshev1GradientEval1
@@ -693,9 +741,9 @@
xx = 2.0_DFP * x
!!
DO i = n - 1, 0, -1
- t = xx * b1 - b2 + (i + 1) * coeff(i + 1);
- b2 = b1;
- b1 = t;
+ t = xx * b1 - b2 + (i + 1) * coeff(i + 1);
+ b2 = b1;
+ b1 = t;
END DO
!!
ans = b1
@@ -714,9 +762,9 @@
xx = 2.0_DFP * x
!!
DO i = n - 1, 0, -1
- t = xx * b1 - b2 + (i + 1) * coeff(i + 1);
- b2 = b1;
- b1 = t;
+ t = xx * b1 - b2 + (i + 1) * coeff(i + 1);
+ b2 = b1;
+ b1 = t;
END DO
!!
ans = b1
@@ -750,9 +798,9 @@
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;
+ & / (j + 2) * b2 + (j + k) * coeff(i + k);
+ b2 = b1;
+ b1 = t;
END DO
!!
ans = s * b1
@@ -788,9 +836,9 @@
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;
+ & / (j + 2) * b2 + (j + k) * coeff(i + k);
+ b2 = b1;
+ b1 = t;
END DO
!!
ans = s * b1
@@ -803,127 +851,168 @@
!----------------------------------------------------------------------------
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
-!!
+INTEGER(I4B) :: tsize
+CALL Chebyshev1Transform1_(n, coeff, x, w, quadType, ans, tsize)
END PROCEDURE Chebyshev1Transform1
!----------------------------------------------------------------------------
-! Chebyshev1Transform
+! 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)
+MODULE PROCEDURE Chebyshev1Transform1_
+REAL(DFP), ALLOCATABLE :: PP(:, :)
+INTEGER(I4B) :: ii, jj, nips
+nips = SIZE(coeff)
+ALLOCATE (PP(nips, n + 1))
+
+CALL Chebyshev1EvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj)
+CALL Chebyshev1Transform4_(n, coeff, PP, w, quadType, ans, tsize)
+
+DEALLOCATE (PP)
+
+END PROCEDURE Chebyshev1Transform1_
+
+!----------------------------------------------------------------------------
+! Chebyshev1Transform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Chebyshev1Transform4_
+INTEGER(I4B) :: ii, jj, nips
+REAL(DFP) :: nrmsqr, areal
+LOGICAL(LGT) :: abool
+
+tsize = n + 1
+nips = SIZE(coeff)
+
+DO jj = 0, n
+ areal = 0.0_DFP
+
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
END DO
+
+ nrmsqr = Chebyshev1NormSQR(n=jj)
+ ans(jj) = areal / nrmsqr
+
END DO
-!!
-END PROCEDURE Chebyshev1Transform2
+
+abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1)
+
+IF (abool) THEN
+ areal = 0.0_DFP
+ jj = n
+
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+
+ nrmsqr = pi
+ ans(jj) = areal / nrmsqr
+END IF
+
+END PROCEDURE Chebyshev1Transform4_
!----------------------------------------------------------------------------
! Chebyshev1Transform
!----------------------------------------------------------------------------
MODULE PROCEDURE Chebyshev1Transform3
-REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n)
+INTEGER(I4B) :: tsize
+CALL Chebyshev1Transform3_(n, f, quadType, x1, x2, ans, tsize)
+END PROCEDURE Chebyshev1Transform3
+
+!----------------------------------------------------------------------------
+! Chebyshev1Transform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Chebyshev1Transform3_
+REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x
+REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP
INTEGER(I4B) :: ii
-!!
-CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt,&
- & quadType=quadType)
-!!
+
+CALL Chebyshev1Quadrature(n=n + 1, pt=pt, wt=wt, quadType=quadType)
+
DO ii = 0, n
- coeff(ii) = f(pt(ii))
+ x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2
+ x = x * half
+ coeff(ii) = f(x)
END DO
-!!
-ans = Chebyshev1Transform(n=n, coeff=coeff, x=pt, &
- & w=wt, quadType=quadType)
-!!
-END PROCEDURE Chebyshev1Transform3
+
+CALL Chebyshev1Transform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, &
+ ans=ans, tsize=tsize)
+
+END PROCEDURE Chebyshev1Transform3_
!----------------------------------------------------------------------------
! Chebyshev1Transform4
!----------------------------------------------------------------------------
-MODULE PROCEDURE Chebyshev1Transform4
-INTEGER(I4B) :: ii, jj
-REAL(DFP) :: avar
-!!
-ans = 0.0_DFP
-!!
-IF (quadType .EQ. GaussLobatto) THEN
- !!
+MODULE PROCEDURE Chebyshev1Transform2
+INTEGER(I4B) :: tsize
+CALL Chebyshev1Transform2_(n, coeff, quadType, ans, tsize)
+END PROCEDURE Chebyshev1Transform2
+
+!----------------------------------------------------------------------------
+! Chebyshev1Transform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Chebyshev1Transform2_
+INTEGER(I4B) :: ii, jj, nips
+REAL(DFP) :: avar, asign, pi_by_n, one_by_n
+REAL(DFP), PARAMETER :: half = 0.5_DFP, minusOne = -1.0_DFP
+LOGICAL(LGT) :: abool
+
+tsize = n + 1
+ans(1:tsize) = 0.0_DFP
+
+nips = SIZE(coeff)
+
+one_by_n = 1.0_DFP / REAL(n, KIND=DFP)
+pi_by_n = pi * one_by_n
+
+abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1)
+
+IF (abool) 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)
+
+ asign = minusOne**jj
+
+ ans(jj) = coeff(0) * half + coeff(n) * half * asign
+
+ DO ii = 1, nips - 1
+ ans(jj) = ans(jj) + coeff(ii) * COS(jj * pi_by_n * ii)
END DO
- !!
- ans(jj) = ans(jj) * 2.0_DFP / n
- !!
+
+ ans(jj) = ans(jj) * 2.0_DFP * one_by_n
+
END DO
- !!
- ans(0) = ans(0) * 0.5_DFP
- ans(n) = ans(n) * 0.5_DFP
- !!
+
+ ans(0) = ans(0) * half
+ ans(n) = ans(n) * half
+
ELSE
- !!
+
+ one_by_n = 1.0_DFP / REAL(n + 1, KIND=DFP)
+ pi_by_n = pi * half * one_by_n
+
DO jj = 0, n
- !!
- avar = jj * pi * 0.5_DFP / (n + 1.0_DFP)
- !!
- DO ii = 0, n
+
+ avar = jj * pi_by_n
+
+ DO ii = 0, nips - 1
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)
- !!
+
+ ans(jj) = ans(jj) * 2.0_DFP * one_by_n
+
END DO
- !!
- ans(0) = ans(0) * 0.5_DFP
- !!
+
+ ans(0) = ans(0) * half
+
END IF
-!!
-END PROCEDURE Chebyshev1Transform4
+
+END PROCEDURE Chebyshev1Transform2_
!----------------------------------------------------------------------------
! Chebyshev1InvTransform
@@ -946,28 +1035,28 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Chebyshev1GradientCoeff1
-REAL(DFP) :: a, b, c
+REAL(DFP) :: 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
!----------------------------------------------------------------------------
@@ -976,9 +1065,9 @@
MODULE PROCEDURE Chebyshev1DMatrix1
SELECT CASE (quadType)
-CASE (GaussLobatto)
+CASE (qp%GaussLobatto)
CALL Chebyshev1DMatrixGL2(n=n, x=x, D=ans)
-CASE (Gauss)
+CASE (qp%Gauss)
CALL Chebyshev1DMatrixG2(n=n, x=x, D=ans)
END SELECT
END PROCEDURE Chebyshev1DMatrix1
@@ -1000,7 +1089,7 @@ PURE SUBROUTINE Chebyshev1DMatrixGL2(n, x, D)
REAL(DFP) :: rn, j1, j2
INTEGER(I4B) :: ii, jj, nb2
!!
- nb2 = int(n / 2)
+ nb2 = INT(n / 2)
rn = REAL(n, KIND=DFP)
!!
D = 0.0_DFP
@@ -1056,7 +1145,7 @@ PURE SUBROUTINE Chebyshev1DMatrixG(n, x, D)
!! main
!!
rn = REAL(n, KIND=DFP)
- nb2 = int(n / 2)
+ nb2 = INT(n / 2)
D = 0.0_DFP
!!
DO jj = 0, n
@@ -1107,7 +1196,7 @@ PURE SUBROUTINE Chebyshev1DMatrixG2(n, x, D)
!! main
!!
rn = REAL(n, KIND=DFP)
- nb2 = int(n / 2)
+ nb2 = INT(n / 2)
D = 0.0_DFP
!!
J = Chebyshev1GradientEval(n=n + 1, x=x)
diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90
index 4e1eb13d0..0bb3ab173 100644
--- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90
@@ -49,8 +49,8 @@
MODULE PROCEDURE GetEdgeDOF_Hexahedron2
ans = GetEdgeDOF_Hexahedron(p, p, p, p) &
- & + GetEdgeDOF_Hexahedron(q, q, q, q) &
- & + GetEdgeDOF_Hexahedron(r, r, r, r)
+ + GetEdgeDOF_Hexahedron(q, q, q, q) &
+ + GetEdgeDOF_Hexahedron(r, r, r, r)
END PROCEDURE GetEdgeDOF_Hexahedron2
!----------------------------------------------------------------------------
@@ -67,8 +67,8 @@
MODULE PROCEDURE GetEdgeDOF_Hexahedron4
ans = GetEdgeDOF_Hexahedron(px1, px2, px3, px4) &
- & + GetEdgeDOF_Hexahedron(py1, py2, py3, py4) &
- & + GetEdgeDOF_Hexahedron(pz1, pz2, pz3, pz4)
+ + GetEdgeDOF_Hexahedron(py1, py2, py3, py4) &
+ + GetEdgeDOF_Hexahedron(pz1, pz2, pz3, pz4)
END PROCEDURE GetEdgeDOF_Hexahedron4
!----------------------------------------------------------------------------
@@ -77,8 +77,8 @@
MODULE PROCEDURE GetFacetDOF_Hexahedron1
ans = GetFacetDOF_Hexahedron(pxy1, pxy2) &
- & + GetFacetDOF_Hexahedron(pxz1, pxz2) &
- & + GetFacetDOF_Hexahedron(pyz1, pyz2)
+ + GetFacetDOF_Hexahedron(pxz1, pxz2) &
+ + GetFacetDOF_Hexahedron(pyz1, pyz2)
ans = 2_I4B * ans
END PROCEDURE GetFacetDOF_Hexahedron1
@@ -88,8 +88,8 @@
MODULE PROCEDURE GetFacetDOF_Hexahedron2
ans = GetFacetDOF_Hexahedron(p, q) &
- & + GetFacetDOF_Hexahedron(p, r) &
- & + GetFacetDOF_Hexahedron(q, r)
+ + GetFacetDOF_Hexahedron(p, r) &
+ + GetFacetDOF_Hexahedron(q, r)
ans = ans * 2_I4B
END PROCEDURE GetFacetDOF_Hexahedron2
@@ -236,9 +236,17 @@
! GetTotalInDOF_Hexahedron
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetTotalInDOF_Hexahedron
+MODULE PROCEDURE GetTotalInDOF_Hexahedron1
ans = (order - 1)**3
-END PROCEDURE GetTotalInDOF_Hexahedron
+END PROCEDURE GetTotalInDOF_Hexahedron1
+
+!----------------------------------------------------------------------------
+! GetTotalInDOF_Hexahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalInDOF_Hexahedron2
+ans = (p - 1) * (q - 1) * (r - 1)
+END PROCEDURE GetTotalInDOF_Hexahedron2
!----------------------------------------------------------------------------
! LagrangeDOF_Hexahedron
@@ -273,90 +281,100 @@
END PROCEDURE LagrangeInDOF_Hexahedron2
!----------------------------------------------------------------------------
-! EquidistancePoint_Hexahedron
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Hexahedron1
-ans = EquidistancePoint_Hexahedron2(p=order, q=order, r=order, xij=xij)
+INTEGER(I4B) :: nrow, ncol
+nrow = 3
+ncol = LagrangeDOF_Hexahedron(order=order)
+ALLOCATE (ans(nrow, ncol))
+CALL EquidistancePoint_Hexahedron1_(order=order, ans=ans, nrow=nrow, &
+ ncol=ncol, xij=xij)
END PROCEDURE EquidistancePoint_Hexahedron1
!----------------------------------------------------------------------------
-! EquidistancePoint_Hexahedron
+! EquidistancePoint_Hexahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Hexahedron1_
+CALL EquidistancePoint_Hexahedron2_(p=order, q=order, r=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE EquidistancePoint_Hexahedron1_
+
+!----------------------------------------------------------------------------
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Hexahedron2
+INTEGER(I4B) :: nrow, ncol
+nrow = 3
+ncol = LagrangeDOF_Hexahedron(p=p, q=q, r=r)
+ALLOCATE (ans(nrow, ncol))
+CALL EquidistancePoint_Hexahedron2_(p=p, q=q, r=r, ans=ans, nrow=nrow, &
+ ncol=ncol, xij=xij)
+END PROCEDURE EquidistancePoint_Hexahedron2
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Hexahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Hexahedron2_
! internal variables
REAL(DFP) :: x(p + 1), y(q + 1), z(r + 1), temp0
REAL(DFP), DIMENSION(p + 1, q + 1, r + 1) :: xi, eta, zeta
REAL(DFP) :: temp(3, (p + 1) * (q + 1) * (r + 1))
INTEGER(I4B) :: ii, jj, kk, nsd
+nrow = 3
+ncol = LagrangeDOF_Hexahedron(p=p, q=q, r=r)
+
x = EquidistancePoint_Line(order=p, xij=[-1.0_DFP, 1.0_DFP])
y = EquidistancePoint_Line(order=q, xij=[-1.0_DFP, 1.0_DFP])
z = EquidistancePoint_Line(order=r, xij=[-1.0_DFP, 1.0_DFP])
-IF (p .GT. 0_I4B) THEN
- temp0 = x(2)
-END IF
-DO ii = 2, p
+
+IF (p .GT. 0_I4B) temp0 = x(2)
+DO CONCURRENT(ii=2:p)
x(ii) = x(ii + 1)
END DO
x(p + 1) = temp0
-IF (q .GT. 0_I4B) THEN
- temp0 = y(2)
-END IF
-DO ii = 2, q
+IF (q .GT. 0_I4B) temp0 = y(2)
+DO CONCURRENT(ii=2:q)
y(ii) = y(ii + 1)
END DO
y(q + 1) = temp0
-IF (r .GT. 0_I4B) THEN
- temp0 = z(2)
-END IF
-DO ii = 2, r
+IF (r .GT. 0_I4B) temp0 = z(2)
+DO CONCURRENT(ii=2:r)
z(ii) = z(ii + 1)
END DO
z(r + 1) = temp0
-nsd = 3
-CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1))
+! nsd = 3
+! CALL Reallocate(ans, nsd, (p + 1) * (q + 1) * (r + 1))
-DO ii = 1, p + 1
- DO jj = 1, q + 1
- DO kk = 1, r + 1
- xi(ii, jj, kk) = x(ii)
- eta(ii, jj, kk) = y(jj)
- zeta(ii, jj, kk) = z(kk)
- END DO
- END DO
+DO CONCURRENT(ii=1:p + 1, jj=1:q + 1, kk=1:r + 1)
+ xi(ii, jj, kk) = x(ii)
+ eta(ii, jj, kk) = y(jj)
+ zeta(ii, jj, kk) = z(kk)
END DO
-CALL IJK2VEFC_Hexahedron( &
- & xi=xi, &
- & eta=eta, &
- & zeta=zeta, &
- & temp=temp, &
- & p=p, &
- & q=q, &
- & r=r)
+CALL IJK2VEFC_Hexahedron(xi=xi, eta=eta, zeta=zeta, temp=temp, p=p, q=q, r=r)
IF (PRESENT(xij)) THEN
- ans = FromBiUnitHexahedron2Hexahedron( &
- & xin=temp, &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4), &
- & x5=xij(:, 5), &
- & x6=xij(:, 6), &
- & x7=xij(:, 7), &
- & x8=xij(:, 8) &
- & )
+
+ ans(1:nrow, 1:ncol) = FromBiUnitHexahedron2Hexahedron(xin=temp, &
+ x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), &
+ x5=xij(:, 5), x6=xij(:, 6), x7=xij(:, 7), x8=xij(:, 8))
+
ELSE
- ans = temp
+
+ ans(1:nrow, 1:ncol) = temp
+
END IF
-END PROCEDURE EquidistancePoint_Hexahedron2
+END PROCEDURE EquidistancePoint_Hexahedron2_
!----------------------------------------------------------------------------
! EquidistanceInPoint_Hexahedron
@@ -505,9 +523,9 @@
MODULE PROCEDURE IJK2VEFC_Hexahedron
! internal variables
-INTEGER(I4B) :: cnt, ii, jj, kk, ll, N, &
+INTEGER(I4B) :: cnt, ii, jj, kk, N, &
& ii1, ii2, jj1, jj2, kk1, kk2, ijk(3, 8), &
- & iedge, iface, p1, p2, dii, djj, dkk, startNode
+ & iedge, p1, p2, dii, djj, dkk, startNode
INTEGER(I4B), PARAMETER :: tPoints = 8, tEdges = 12, tFacets = 6
INTEGER(I4B) :: edgeConnectivity(2, tEdges)
INTEGER(I4B) :: facetConnectivity(4, tFacets)
@@ -821,212 +839,189 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Hexahedron1
-REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Hexahedron1_(order=order, i=i, xij=xij, ans=ans, &
+ tsize=tsize)
+END PROCEDURE LagrangeCoeff_Hexahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Hexahedron1_
+REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: v
INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
-INTEGER(I4B) :: info
+INTEGER(I4B) :: info, nrow, ncol
-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)
+tsize = SIZE(xij, 2)
-END PROCEDURE LagrangeCoeff_Hexahedron1
+ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Hexahedron, &
+ ans=v, nrow=nrow, ncol=ncol)
+CALL GetLU(A=v, IPIV=ipiv, info=info)
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+
+END PROCEDURE LagrangeCoeff_Hexahedron1_
!----------------------------------------------------------------------------
! LagrangeCoeff_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Hexahedron2
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Hexahedron2_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff_Hexahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
+
+tsize = SIZE(v, 1)
+
+vtemp = v; ans(1:tsize) = 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
+CALL LUSolve(A=vtemp, B=ans(1:tsize), 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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Hexahedron3_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Hexahedron3
!----------------------------------------------------------------------------
-! LagrangeCoeff_Hexahedron
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeCoeff_Hexahedron4
-INTEGER(I4B) :: basisType0, ii, jj, kk, indx
-REAL(DFP) :: ans1(SIZE(xij, 2), 0:order)
-REAL(DFP) :: ans2(SIZE(xij, 2), 0:order)
-REAL(DFP) :: ans3(SIZE(xij, 2), 0:order)
+MODULE PROCEDURE LagrangeCoeff_Hexahedron3_
+INTEGER(I4B) :: info
-basisType0 = Input(default=Monomial, option=basisType)
+tsize = SIZE(v, 1)
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Hexahedron3_
-SELECT CASE (basisType0)
-CASE (Monomial)
- ans = LagrangeVandermonde(order=order, xij=xij, elemType=Hexahedron)
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Hexahedron
+!----------------------------------------------------------------------------
-CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical)
+MODULE PROCEDURE LagrangeCoeff_Hexahedron4
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff_Hexahedron5_(p=order, q=order, r=order, xij=xij, &
+ basisType1=basisType, basisType2=basisType, basisType3=basisType, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, &
+ lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, &
+ refHexahedron=refHexahedron, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeCoeff_Hexahedron4
- IF (basisType0 .EQ. Jacobi) THEN
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL Errormsg(&
- & msg="alpha and beta should be present for basisType=Jacobi", &
- & file=__FILE__, &
- & routine="LagrangeCoeff_Hexahedron4", &
- & line=__LINE__, &
- & unitno=stderr)
- STOP
- END IF
- END IF
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
- IF (basisType0 .EQ. Ultraspherical) THEN
- IF (.NOT. PRESENT(lambda)) THEN
- CALL Errormsg(&
- & msg="lambda should be present for basisType=Ultraspherical", &
- & file=__FILE__, &
- & routine="LagrangeCoeff_Hexahedron4", &
- & line=__LINE__, &
- & unitno=stderr)
- STOP
- END IF
- END IF
+MODULE PROCEDURE LagrangeCoeff_Hexahedron4_
+CALL LagrangeCoeff_Hexahedron5_(p=order, q=order, r=order, xij=xij, &
+ basisType1=basisType, basisType2=basisType, basisType3=basisType, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, &
+ lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, &
+ refHexahedron=refHexahedron, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeCoeff_Hexahedron4_
- ans1 = EvalAllOrthopol( &
- & n=order, &
- & x=xij(1, :), &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-
- ans2 = EvalAllOrthopol( &
- & n=order, &
- & x=xij(2, :), &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-
- ans3 = EvalAllOrthopol( &
- & n=order, &
- & x=xij(3, :), &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-
- indx = 0
- DO kk = 0, order
- DO jj = 0, order
- DO ii = 0, order
- indx = indx + 1
- ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk)
- END DO
- END DO
- END DO
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for basisType = "//tostring(basisType0), &
- & file=__FILE__, &
- & routine="LagrangeCoeff_Hexahedron4()", &
- & line=__LINE__, &
- & unitno=stderr)
- STOP
-END SELECT
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Hexahedron4
+MODULE PROCEDURE LagrangeCoeff_Hexahedron5
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff_Hexahedron5_(p=p, q=q, r=r, xij=xij, &
+ basisType1=basisType1, basisType2=basisType2, basisType3=basisType3, &
+ alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, beta2=beta2, &
+ lambda2=lambda2, alpha3=alpha3, beta3=beta3, lambda3=lambda3, &
+ refHexahedron=refHexahedron, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeCoeff_Hexahedron5
!----------------------------------------------------------------------------
! LagrangeCoeff_Hexahedron
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeCoeff_Hexahedron5
+MODULE PROCEDURE LagrangeCoeff_Hexahedron5_
INTEGER(I4B) :: basisType0, ii, jj, kk, indx, basisType(3)
REAL(DFP) :: ans1(SIZE(xij, 2), 0:p)
REAL(DFP) :: ans2(SIZE(xij, 2), 0:q)
REAL(DFP) :: ans3(SIZE(xij, 2), 0:r)
-basisType(1) = input(default=Monomial, option=basisType1)
-basisType(2) = input(default=Monomial, option=basisType2)
-basisType(3) = input(default=Monomial, option=basisType3)
+basisType(1) = Input(default=Monomial, option=basisType1)
+basisType(2) = Input(default=Monomial, option=basisType2)
+basisType(3) = Input(default=Monomial, option=basisType3)
+
+nrow = SIZE(xij, 2)
+ncol = nrow
basisType0 = basisType(1)
SELECT CASE (basisType0)
CASE (Monomial)
- ans1 = LagrangeVandermonde(order=p, xij=xij(1:1, :), elemType=Line)
+ CALL LagrangeVandermonde_(order=p, xij=xij(1:1, :), elemType=Line, &
+ ans=ans1, nrow=ii, ncol=jj)
CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical)
-
- ans1 = EvalAllOrthopol( &
- & n=p, &
- & x=xij(1, :), &
- & orthopol=basisType0, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
+ CALL EvalAllOrthopol_(n=p, x=xij(1, :), orthopol=basisType0, &
+ alpha=alpha1, beta=beta1, lambda=lambda1, &
+ ans=ans1, nrow=ii, ncol=jj)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for basisType1", &
- & file=__FILE__, &
- & routine="LagrangeCoeff_Hexahedron5", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg(msg="No case found for basisType1", &
+ routine="LagrangeCoeff_Hexahedron5", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ RETURN
END SELECT
basisType0 = basisType(2)
SELECT CASE (basisType0)
CASE (Monomial)
- ans2 = LagrangeVandermonde(order=q, xij=xij(2:2, :), elemType=Line)
+ CALL LagrangeVandermonde_(order=q, xij=xij(2:2, :), elemType=Line, &
+ ans=ans2, nrow=ii, ncol=jj)
CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical)
- ans2 = EvalAllOrthopol( &
- & n=q, &
- & x=xij(2, :), &
- & orthopol=basisType0, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
+ CALL EvalAllOrthopol_(n=q, x=xij(2, :), orthopol=basisType0, &
+ alpha=alpha2, beta=beta2, lambda=lambda2, &
+ ans=ans2, nrow=ii, ncol=jj)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for basisType2", &
- & file=__FILE__, &
- & routine="LagrangeCoeff_Hexahedron5", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg(msg="No case found for basisType2", &
+ routine="LagrangeCoeff_Hexahedron5", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
END SELECT
basisType0 = basisType(3)
SELECT CASE (basisType0)
CASE (Monomial)
- ans3 = LagrangeVandermonde(order=r, xij=xij(3:3, :), elemType=Line)
+ CALL LagrangeVandermonde_(order=r, xij=xij(3:3, :), elemType=Line, &
+ ans=ans3, nrow=ii, ncol=jj)
CASE (Legendre, Jacobi, Lobatto, Chebyshev, Ultraspherical)
-
- ans3 = EvalAllOrthopol( &
- & n=r, &
- & x=xij(3, :), &
- & orthopol=basisType0, &
- & alpha=alpha3, &
- & beta=beta3, &
- & lambda=lambda3)
+ CALL EvalAllOrthopol_(n=r, x=xij(3, :), orthopol=basisType0, &
+ alpha=alpha3, beta=beta3, lambda=lambda3, &
+ ans=ans3, nrow=ii, ncol=jj)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for basisType3", &
- & file=__FILE__, &
- & routine="LagrangeCoeff_Hexahedron5", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg(msg="No case found for basisType3", &
+ routine="LagrangeCoeff_Hexahedron5", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ RETURN
END SELECT
indx = 0
@@ -1034,109 +1029,112 @@
DO jj = 0, q
DO ii = 0, p
indx = indx + 1
- ans(:, indx) = ans1(:, ii) * ans2(:, jj) * ans3(:, kk)
+ ans(1:nrow, indx) = &
+ ans1(1:nrow, ii) * ans2(1:nrow, jj) * ans3(1:nrow, kk)
END DO
END DO
END DO
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Hexahedron5
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Hexahedron5_
!----------------------------------------------------------------------------
! TensorProdBasis_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorProdBasis_Hexahedron1
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2))
-REAL(DFP) :: P1(SIZE(xij, 2), p + 1)
-REAL(DFP) :: Q1(SIZE(xij, 2), q + 1)
-REAL(DFP) :: R1(SIZE(xij, 2), r + 1)
-INTEGER(I4B) :: ii, k1, k2, k3, cnt
-
-x = xij(1, :)
-y = xij(2, :)
-z = xij(3, :)
-
-P1 = BasisEvalAll_Line( &
- & order=p, &
- & x=x, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-Q1 = BasisEvalAll_Line( &
- & order=q, &
- & x=y, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-
-R1 = BasisEvalAll_Line( &
- & order=r, &
- & x=z, &
- & refLine="BIUNIT", &
- & basisType=basisType3, &
- & alpha=alpha3, &
- & beta=beta3, &
- & lambda=lambda3)
+INTEGER(I4B) :: nrow, ncol
+CALL TensorProdBasis_Hexahedron1_(p, q, r, xij, basisType1, &
+ basisType2, basisType3, ans, nrow, ncol, &
+ alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3)
+END PROCEDURE TensorProdBasis_Hexahedron1
-cnt = 0
+!----------------------------------------------------------------------------
+! TensorProdBasis_Hexahedron
+!----------------------------------------------------------------------------
-DO k3 = 1, r + 1
- DO k2 = 1, q + 1
- DO k1 = 1, p + 1
- cnt = cnt + 1
- ans(:, cnt) = P1(:, k1) * Q1(:, k2) * R1(:, k3)
- END DO
- END DO
+MODULE PROCEDURE TensorProdBasis_Hexahedron1_
+INTEGER(I4B) :: ii, k1, k2, k3, o(3), p1, q1, r1
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+nrow = SIZE(xij, 2)
+p1 = p + 1
+q1 = q + 1
+r1 = r + 1
+ncol = p1 * q1 * r1
+
+ALLOCATE (temp(nrow, ncol))
+
+o(1) = 0
+o(2) = o(1) + p1
+o(3) = o(2) + q1
+
+k1 = 1
+CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, &
+ ans=temp(:, k1:), nrow=k2, ncol=k3)
+k1 = k1 + k3
+
+CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", &
+ basisType=basisType2, alpha=alpha2, beta=beta2, lambda=lambda2, &
+ ans=temp(:, k1:), nrow=k2, ncol=k3)
+k1 = k1 + k3
+
+CALL BasisEvalAll_Line_(order=r, x=xij(3, :), refLine="BIUNIT", &
+ basisType=basisType3, alpha=alpha3, beta=beta3, lambda=lambda3, &
+ ans=temp(:, k1:), nrow=k2, ncol=k3)
+k1 = k1 + k3
+
+DO CONCURRENT(ii=1:nrow, k1=1:p1, k2=1:q1, k3=1:r1)
+ ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = &
+ temp(ii, o(1) + k1) * temp(ii, o(2) + k2) * temp(ii, o(3) + k3)
END DO
-END PROCEDURE TensorProdBasis_Hexahedron1
+DEALLOCATE (temp)
+
+END PROCEDURE TensorProdBasis_Hexahedron1_
!----------------------------------------------------------------------------
! TensorProdBasis_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorProdBasis_Hexahedron2
-REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z))
-INTEGER(I4B) :: ii, jj, cnt, kk
+INTEGER(I4B) :: nrow, ncol
+CALL TensorProdBasis_Hexahedron2_(p, q, r, x, y, z, basisType1, basisType2, &
+ basisType3, ans, nrow, ncol, alpha1, beta1, lambda1, alpha2, beta2, &
+ lambda2, alpha3, beta3, lambda3)
+END PROCEDURE TensorProdBasis_Hexahedron2
-xij = 0.0_DFP
-cnt = 0
-DO ii = 1, SIZE(x)
- DO jj = 1, SIZE(y)
- DO kk = 1, SIZE(z)
- cnt = cnt + 1
- xij(1, cnt) = x(ii)
- xij(2, cnt) = y(jj)
- xij(3, cnt) = z(kk)
- END DO
- END DO
+!----------------------------------------------------------------------------
+! TensorProdBasis_Hexahedron2_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasis_Hexahedron2_
+REAL(DFP), ALLOCATABLE :: xij(:, :)
+INTEGER(I4B) :: ii, p1, q1, r1, k1, k2, k3
+
+p1 = SIZE(x, 1)
+q1 = SIZE(y, 1)
+r1 = SIZE(z, 1)
+ii = p1 * q1 * r1
+ALLOCATE (xij(3, ii))
+
+DO CONCURRENT(k1=1:p1, k2=1:q1, k3=1:r1)
+ xij(1, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = x(k1)
+ xij(2, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = y(k2)
+ xij(3, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1)) = z(k3)
END DO
-ans = TensorProdBasis_Hexahedron1( &
- & p=p, &
- & q=q, &
- & r=r, &
- & xij=xij, &
- & basisType1=basisType1, &
- & basisType2=basisType2, &
- & basisType3=basisType3, &
- & alpha1=alpha1, &
- & alpha2=alpha2, &
- & alpha3=alpha3, &
- & beta1=beta1, &
- & beta2=beta2, &
- & beta3=beta3, &
- & lambda1=lambda1, &
- & lambda2=lambda2, &
- & lambda3=lambda3)
+CALL TensorProdBasis_Hexahedron1_(p=p, q=q, r=r, xij=xij, &
+ basisType1=basisType1, basisType2=basisType2, basisType3=basisType3, &
+ alpha1=alpha1, alpha2=alpha2, alpha3=alpha3, beta1=beta1, beta2=beta2, &
+ beta3=beta3, lambda1=lambda1, lambda2=lambda2, lambda3=lambda3, &
+ ans=ans, nrow=nrow, ncol=ncol)
-END PROCEDURE TensorProdBasis_Hexahedron2
+DEALLOCATE (xij)
+
+END PROCEDURE TensorProdBasis_Hexahedron2_
!----------------------------------------------------------------------------
! VertexBasis_Hexahedron
@@ -2038,59 +2036,69 @@
END PROCEDURE CellBasisGradient_Hexahedron2
!----------------------------------------------------------------------------
-! HeirarchicalBasis_Hexahedron
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasis_Hexahedron1
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Hexahedron1_(pb1=pb1, pb2=pb2, pb3=pb3, pxy1=pxy1, &
+ pxy2=pxy2, pxz1=pxz1, pxz2=pxz2, pyz1=pyz1, pyz2=pyz2, px1=px1, px2=px2, &
+ px3=px3, px4=px4, py1=py1, py2=py2, py3=py3, py4=py4, pz1=pz1, pz2=pz2, &
+ pz3=pz3, pz4=pz4, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Hexahedron1
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Hexahedron
+!----------------------------------------------------------------------------
-#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1])
-#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1])
-#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2])
+MODULE PROCEDURE HeirarchicalBasis_Hexahedron1_
+INTEGER(I4B) :: a, b, maxP, maxQ, maxR, indx(2)
+REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :), L3(:, :)
-INTEGER(I4B) :: a, b, maxP, maxQ, maxR
-REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_)
-REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_)
-REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_)
+nrow = SIZE(xij, 2)
+ncol = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) &
+ + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B &
+ + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B &
+ + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B &
+ + (px1 + px2 + px3 + px4 - 4_I4B) &
+ + (py1 + py2 + py3 + py4 - 4_I4B) &
+ + (pz1 + pz2 + pz3 + pz4 - 4_I4B)
-#undef _maxP_
-#undef _maxQ_
-#undef _maxR_
+maxP = MAX(pb1, px1, px2, px3, px4, pxy1, pxz1)
+maxQ = MAX(pb2, py1, py2, py3, py4, pxy2, pyz1)
+maxR = MAX(pb3, pz1, pz2, pz3, pz4, pxz2, pyz2)
-maxP = SIZE(L1, 2) - 1
-maxQ = SIZE(L2, 2) - 1
-maxR = SIZE(L3, 2) - 1
+ALLOCATE (L1(1:nrow, 0:maxP), L2(1:nrow, 0:maxQ), L3(1:nrow, 0:maxR))
-L1 = LobattoEvalAll(n=maxP, x=xij(1, :))
-L2 = LobattoEvalAll(n=maxQ, x=xij(2, :))
-L3 = LobattoEvalAll(n=maxR, x=xij(3, :))
+CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2))
+CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2))
+CALL LobattoEvalAll_(n=maxR, x=xij(3, :), ans=L3, nrow=indx(1), ncol=indx(2))
! Vertex basis function
-
-ans(:, 1:8) = VertexBasis_Hexahedron2(L1=L1, L2=L2, L3=L3)
+ans(1:nrow, 1:8) = VertexBasis_Hexahedron2(L1=L1, L2=L2, L3=L3)
! Edge basis function
-
b = 8
IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + px1 + px2 + px3 + px4 - 4
- ans(:, a:b) = xEdgeBasis_Hexahedron2( &
- & pe1=px1, pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = xEdgeBasis_Hexahedron2( &
+ pe1=px1, pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3)
END IF
IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + py1 + py2 + py3 + py4 - 4
- ans(:, a:b) = yEdgeBasis_Hexahedron2( &
- & pe1=py1, pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = yEdgeBasis_Hexahedron2( &
+ pe1=py1, pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3)
END IF
IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4
- ans(:, a:b) = zEdgeBasis_Hexahedron2( &
- & pe1=pz1, pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = zEdgeBasis_Hexahedron2( &
+ pe1=pz1, pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3)
END IF
! Facet basis function
@@ -2098,278 +2106,257 @@
IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1)
- ans(:, a:b) = xyFacetBasis_Hexahedron2( &
- & n1=pxy1, n2=pxy2, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = xyFacetBasis_Hexahedron2( &
+ n1=pxy1, n2=pxy2, L1=L1, L2=L2, L3=L3)
END IF
IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1)
- ans(:, a:b) = xzFacetBasis_Hexahedron2( &
- & n1=pxz1, n2=pxz2, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = xzFacetBasis_Hexahedron2( &
+ n1=pxz1, n2=pxz2, L1=L1, L2=L2, L3=L3)
END IF
IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1)
- ans(:, a:b) = yzFacetBasis_Hexahedron2( &
- & n1=pyz1, n2=pyz2, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = yzFacetBasis_Hexahedron2( &
+ n1=pyz1, n2=pyz2, L1=L1, L2=L2, L3=L3)
END IF
IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1)
- ans(:, a:b) = cellBasis_Hexahedron2( &
- & n1=pb1, n2=pb2, n3=pb3, L1=L1, L2=L2, L3=L3)
+ ans(1:nrow, a:b) = cellBasis_Hexahedron2( &
+ n1=pb1, n2=pb2, n3=pb3, L1=L1, L2=L2, L3=L3)
END IF
-END PROCEDURE HeirarchicalBasis_Hexahedron1
+END PROCEDURE HeirarchicalBasis_Hexahedron1_
!----------------------------------------------------------------------------
-! HeirarchicalBasis_Hexahedron
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasis_Hexahedron2
-ans = HeirarchicalBasis_Hexahedron1(&
- & pb1=p, pb2=q, pb3=r, &
- & pxy1=p, pxy2=q, &
- & pxz1=p, pxz2=r, &
- & pyz1=q, pyz2=r, &
- & px1=p, px2=p, px3=p, px4=p, &
- & py1=q, py2=q, py3=q, py4=q, &
- & pz1=r, pz2=r, pz3=r, pz4=r, &
- & xij=xij)
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Hexahedron2_(p=p, q=q, r=r, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
END PROCEDURE HeirarchicalBasis_Hexahedron2
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Hexahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Hexahedron2_
+CALL HeirarchicalBasis_Hexahedron1_(pb1=p, pb2=q, pb3=r, pxy1=p, pxy2=q, &
+ pxz1=p, pxz2=r, pyz1=q, pyz2=r, px1=p, px2=p, px3=p, px4=p, py1=q, py2=q, &
+ py3=q, py4=q, pz1=r, pz2=r, pz3=r, pz4=r, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Hexahedron2_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Hexahedron1
-ans = QuadraturePoint_Hexahedron2( &
- & p=order, &
- & q=order, &
- & r=order, &
- & quadType1=quadType, &
- & quadType2=quadType, &
- & quadType3=quadType, &
- & refHexahedron=refHexahedron, &
- & xij=xij, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda, &
- & alpha3=alpha, &
- & beta3=beta, &
- & lambda3=lambda &
- & )
+INTEGER(I4B) :: nrow, ncol, nips(1)
+
+nips(1) = QuadratureNumber_Line(quadType=quadType, order=order)
+
+nrow = 4
+ncol = nips(1) * nips(1) * nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, &
+ quadType1=quadType, quadType2=quadType, quadType3=quadType, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, &
+ beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE QuadraturePoint_Hexahedron1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Hexahedron1_
+CALL QuadraturePoint_Hexahedron2_(p=order, q=order, r=order, &
+ quadType1=quadType, quadType2=quadType, quadType3=quadType, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, &
+ beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE QuadraturePoint_Hexahedron1_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Hexahedron2
-! internal variables
-REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), z(:, :), temp(:, :)
-INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt
-TYPE(String) :: astr
+INTEGER(I4B), DIMENSION(1) :: nipsx, nipsy, nipsz
+INTEGER(I4B) :: nrow, ncol
-astr = UpperCase(refHexahedron)
+nipsx(1) = QuadratureNumber_Line(quadType=quadType1, order=p)
+nipsy(1) = QuadratureNumber_Line(quadType=quadType2, order=q)
+nipsz(1) = QuadratureNumber_Line(quadType=quadType3, order=r)
-x = QuadraturePoint_Line( &
- & order=p, &
- & quadType=quadType1, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-np = SIZE(x, 2)
-
-y = QuadraturePoint_Line( &
- & order=q, &
- & quadType=quadType2, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-nq = SIZE(y, 2)
-
-z = QuadraturePoint_Line( &
- & order=r, &
- & quadType=quadType2, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha3, &
- & beta=beta3, &
- & lambda=lambda3)
-nr = SIZE(z, 2)
+nrow = 4
+ncol = nipsx(1) * nipsy(1) * nipsz(1)
-nsd = 3
-CALL Reallocate(ans, 4_I4B, np * nq * nr)
-CALL Reallocate(temp, 4_I4B, np * nq * nr)
+ALLOCATE (ans(nrow, ncol))
-cnt = 0
-DO ii = 1, np
- DO jj = 1, nq
- DO kk = 1, nr
- cnt = cnt + 1
- temp(1, cnt) = x(1, ii)
- temp(2, cnt) = y(1, jj)
- temp(3, cnt) = z(1, kk)
- temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk)
- END DO
- END DO
-END DO
+CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, &
+ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ alpha3=alpha3, beta3=beta3, lambda3=lambda3, ans=ans, nrow=nrow, ncol=ncol)
-IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( &
- & xin=temp(1:3, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4), &
- & x5=xij(:, 5), &
- & x6=xij(:, 6), &
- & x7=xij(:, 7), &
- & x8=xij(:, 8) &
- & )
- ans(4, :) = temp(4, :) * JacobianHexahedron( &
- & from="BIUNIT", to="HEXAHEDRON", xij=xij)
+END PROCEDURE QuadraturePoint_Hexahedron2
-ELSE
- IF (astr%chars() .EQ. "UNIT") THEN
- ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( &
- & xin=temp(1:3, :))
- ans(4, :) = temp(4, :) * JacobianHexahedron( &
- & from="BIUNIT", to="UNIT", xij=xij)
- ELSE
- ans = temp
- END IF
-END IF
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
-IF (ALLOCATED(x)) DEALLOCATE (x)
-IF (ALLOCATED(y)) DEALLOCATE (y)
-IF (ALLOCATED(z)) DEALLOCATE (z)
+MODULE PROCEDURE QuadraturePoint_Hexahedron2_
+INTEGER(I4B), DIMENSION(1) :: nipsx, nipsy, nipsz
-END PROCEDURE QuadraturePoint_Hexahedron2
+nipsx(1) = QuadratureNumber_Line(quadType=quadType1, order=p)
+nipsy(1) = QuadratureNumber_Line(quadType=quadType2, order=q)
+nipsz(1) = QuadratureNumber_Line(quadType=quadType3, order=r)
+
+CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, &
+ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ alpha3=alpha3, beta3=beta3, lambda3=lambda3, ans=ans, nrow=nrow, ncol=ncol)
+
+END PROCEDURE QuadraturePoint_Hexahedron2_
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Hexahedron3
-ans = QuadraturePoint_Hexahedron4( &
- & nipsx=nips, &
- & nipsy=nips, &
- & nipsz=nips, &
- & quadType1=quadType, &
- & quadType2=quadType, &
- & quadType3=quadType, &
- & refHexahedron=refHexahedron, &
- & xij=xij, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda, &
- & alpha3=alpha, &
- & beta3=beta, &
- & lambda3=lambda &
- & )
+INTEGER(I4B) :: nrow, ncol
+
+nrow = 4
+ncol = nips(1) * nips(1) * nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, &
+ quadType1=quadType, quadType2=quadType, quadType3=quadType, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, &
+ beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
END PROCEDURE QuadraturePoint_Hexahedron3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Hexahedron3_
+CALL QuadraturePoint_Hexahedron4_(nipsx=nips, nipsy=nips, nipsz=nips, &
+ quadType1=quadType, quadType2=quadType, quadType3=quadType, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, alpha3=alpha, &
+ beta3=beta, lambda3=lambda, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE QuadraturePoint_Hexahedron3_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Hexahedron4
-! internal variables
-REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), z(2, nipsz(1)), &
-& temp(4, nipsy(1) * nipsx(1) * nipsz(1))
-INTEGER(I4B) :: ii, jj, kk, nsd, np, nq, nr, cnt
-TYPE(String) :: astr
+INTEGER(I4B) :: nrow, ncol
-astr = UpperCase(refHexahedron)
+nrow = 4
+ncol = nipsx(1) * nipsy(1) * nipsz(1)
-x = QuadraturePoint_Line( &
- & nips=nipsx, &
- & quadType=quadType1, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-np = SIZE(x, 2)
-
-y = QuadraturePoint_Line( &
- & nips=nipsy, &
- & quadType=quadType2, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-nq = SIZE(y, 2)
-
-z = QuadraturePoint_Line( &
- & nips=nipsz, &
- & quadType=quadType3, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha3, &
- & beta=beta3, &
- & lambda=lambda3)
-nr = SIZE(z, 2)
+ALLOCATE (ans(nrow, ncol))
-nsd = 3
-CALL Reallocate(ans, 4_I4B, np * nq * nr)
+CALL QuadraturePoint_Hexahedron4_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadType1=quadType1, quadType2=quadType2, quadType3=quadType3, &
+ refHexahedron=refHexahedron, xij=xij, alpha1=alpha1, beta1=beta1, &
+ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ alpha3=alpha3, beta3=beta3, lambda3=lambda3, ans=ans, nrow=nrow, ncol=ncol)
-cnt = 0
-DO ii = 1, np
- DO jj = 1, nq
- DO kk = 1, nr
- cnt = cnt + 1
- temp(1, cnt) = x(1, ii)
- temp(2, cnt) = y(1, jj)
- temp(3, cnt) = z(1, kk)
- temp(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk)
- END DO
- END DO
-END DO
+END PROCEDURE QuadraturePoint_Hexahedron4
-IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( &
- & xin=temp(1:3, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4), &
- & x5=xij(:, 5), &
- & x6=xij(:, 6), &
- & x7=xij(:, 7), &
- & x8=xij(:, 8) &
- & )
- ans(4, :) = temp(4, :) * JacobianHexahedron( &
- & from="BIUNIT", to="HEXAHEDRON", xij=xij)
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Hexahedron4_
+INTEGER(I4B), PARAMETER :: nsd = 3
+
+REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), z(2, nipsz(1)), areal
+
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2])
+
+CHARACTER(len=1) :: astr
+
+nrow = 4
+ncol = nipsx(1) * nipsy(1) * nipsz(1)
+
+CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadType1, xij=x12, &
+ layout="INCREASING", alpha=alpha1, beta=beta1, &
+ lambda=lambda1, ans=x, nrow=ii, ncol=jj)
+
+CALL QuadraturePoint_Line_(nips=nipsy, quadType=quadType2, xij=x12, &
+ layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, &
+ ans=y, nrow=ii, ncol=jj)
+
+CALL QuadraturePoint_Line_(nips=nipsz, quadType=quadType3, xij=x12, &
+ layout="INCREASING", alpha=alpha3, beta=beta3, lambda=lambda3, ans=z, &
+ nrow=ii, ncol=jj)
+
+cnt = 0
+DO ii = 1, nipsx(1)
+ DO jj = 1, nipsy(1)
+ DO kk = 1, nipsz(1)
+ cnt = cnt + 1
+ ans(1, cnt) = x(1, ii)
+ ans(2, cnt) = y(1, jj)
+ ans(3, cnt) = z(1, kk)
+ ans(4, cnt) = x(2, ii) * y(2, jj) * z(2, kk)
+ END DO
+ END DO
+END DO
+
+IF (PRESENT(xij)) THEN
+ ! ans(1:nsd, :) = FromBiUnitHexahedron2Hexahedron( &
+ CALL FromBiUnitHexahedron2Hexahedron_(xin=ans(1:nsd, 1:ncol), x1=xij(:, 1), &
+ x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), x5=xij(:, 5), x6=xij(:, 6), &
+ x7=xij(:, 7), x8=xij(:, 8), ans=ans, nrow=ii, ncol=jj)
+
+ areal = JacobianHexahedron(from="BIUNIT", to="HEXAHEDRON", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
-ELSE
- IF (astr%chars() .EQ. "UNIT") THEN
- ans(1:nsd, :) = FromBiUnitHexahedron2UnitHexahedron( &
- & xin=temp(1:3, :))
- ans(4, :) = temp(4, :) * JacobianHexahedron( &
- & from="BIUNIT", to="UNIT", xij=xij)
- ELSE
- ans = temp
- END IF
END IF
-END PROCEDURE QuadraturePoint_Hexahedron4
+astr = UpperCase(refhexahedron(1:1))
+
+IF (astr .EQ. "U") THEN
+ CALL FromBiUnitHexahedron2UnitHexahedron_(xin=ans(1:nsd, 1:ncol), ans=ans, &
+ nrow=ii, ncol=jj)
+
+ areal = JacobianHexahedron(from="BIUNIT", to="UNIT", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
+END IF
+
+END PROCEDURE QuadraturePoint_Hexahedron4_
!----------------------------------------------------------------------------
! LagrangeEvallAll_Hexahedron
@@ -2472,39 +2459,35 @@
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeEvalAll_Hexahedron2
+MODULE PROCEDURE LagrangeEvalAll_Hexahedron1_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof
+INTEGER(I4B) :: ii, basisType0, indx(7)
INTEGER(I4B) :: degree(SIZE(xij, 2), 3)
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2))
-REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2))
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), &
+ x31(3, 1)
+
+tsize = SIZE(xij, 2)
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Hexahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
- coeff0 = coeff
- ELSE
- coeff0 = coeff
+
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff, nrow=indx(1), ncol=indx(2))
+
END IF
+
+ coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize)
+
ELSE
- coeff0 = LagrangeCoeff_Hexahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
+
+ ! coeff0 = LagrangeCoeff_Hexahedron(&
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, ans=coeff0, &
+ nrow=indx(1), ncol=indx(2), basisType=basisType0, alpha=alpha, &
+ beta=beta, lambda=lambda)
END IF
SELECT CASE (basisType0)
@@ -2512,112 +2495,201 @@
CASE (Monomial)
degree = LagrangeDegree_Hexahedron(order=order)
- tdof = SIZE(xij, 2)
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Hexahedron1", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+
+ IF (tsize .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Hexahedron1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
- DO ii = 1, tdof
- xx(:, ii) = x(1, :)**degree(ii, 1) &
- & * x(2, :)**degree(ii, 2) &
- & * x(3, :)**degree(ii, 3)
+#endif
+
+ DO ii = 1, tsize
+ indx(1:3) = degree(ii, 1:3)
+ xx(1, ii) = x(1)**indx(1) * x(2)**indx(2) * x(3)**indx(3)
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasis_Hexahedron( &
- & p=order, &
- & q=order, &
- & r=order, &
- & xij=x)
+ x31(1:3, 1) = x(1:3)
+ xx = HeirarchicalBasis_Hexahedron(p=order, q=order, r=order, xij=x31)
CASE DEFAULT
- xx = TensorProdBasis_Hexahedron( &
- & p=order, &
- & q=order, &
- & r=order, &
- & xij=x, &
- & basisType1=basisType0, &
- & basisType2=basisType0, &
- & basisType3=basisType0, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda, &
- & alpha3=alpha, &
- & beta3=beta, &
- & lambda3=lambda)
+ x31(1:3, 1) = x(1:3)
+
+ xx = TensorProdBasis_Hexahedron(p=order, q=order, r=order, xij=x31, &
+ basisType1=basisType0, basisType2=basisType0, basisType3=basisType0, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, &
+ lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda)
END SELECT
-ans = MATMUL(xx, coeff0)
+DO ii = 1, tsize
+ ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :))
+END DO
+
+END PROCEDURE LagrangeEvalAll_Hexahedron1_
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Hexahedron2
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll_Hexahedron2_(order=order, x=x, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
END PROCEDURE LagrangeEvalAll_Hexahedron2
!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Hexahedron
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Hexahedron2_
+LOGICAL(LGT) :: firstCall0
+INTEGER(I4B) :: ii, jj, basisType0, indx(3), degree(SIZE(xij, 2), 3)
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), &
+ xx(SIZE(x, 2), SIZE(xij, 2)), areal
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
+
+basisType0 = INPUT(default=Monomial, option=basisType)
+firstCall0 = INPUT(default=.TRUE., option=firstCall)
+
+IF (PRESENT(coeff)) THEN
+ IF (firstCall0) THEN
+ ! coeff = LagrangeCoeff_Hexahedron(&
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff, &
+ nrow=indx(1), ncol=indx(2))
+
+ END IF
+
+ coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol)
+
+ELSE
+
+ ! coeff0 = LagrangeCoeff_Hexahedron(&
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, &
+ nrow=indx(1), ncol=indx(2))
+
+END IF
+
+SELECT CASE (basisType0)
+
+CASE (Monomial)
+
+ degree = LagrangeDegree_Hexahedron(order=order)
+
+#ifdef DEBUG_VER
+ IF (ncol .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="ncol is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Hexahedron1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
+ END IF
+#endif
+
+ DO ii = 1, ncol
+
+ indx(1:3) = degree(ii, 1:3)
+
+ DO jj = 1, nrow
+ areal = x(1, jj)**indx(1) * x(2, jj)**indx(2) * x(3, jj)**indx(3)
+ xx(jj, ii) = areal
+ END DO
+
+ END DO
+
+CASE (Heirarchical)
+
+ xx = HeirarchicalBasis_Hexahedron(p=order, q=order, r=order, xij=x)
+
+CASE DEFAULT
+
+ xx = TensorProdBasis_Hexahedron(p=order, q=order, r=order, xij=x, &
+ basisType1=basisType0, basisType2=basisType0, basisType3=basisType0, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, &
+ lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda)
+
+END SELECT
+
+! ans = MATMUL(xx, coeff0)
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0)
+
+END PROCEDURE LagrangeEvalAll_Hexahedron2_
+
+!----------------------------------------------------------------------------
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll_Hexahedron1
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll_Hexahedron1_(order=order, x=x, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE LagrangeGradientEvalAll_Hexahedron1
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Hexahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Hexahedron1_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci
-INTEGER(I4B) :: degree(SIZE(xij, 2), 3), d1, d2, d3
+INTEGER(I4B) :: ii, basisType0, ai, bi, ci,d1, d2, d3, degree(SIZE(xij, 2), 3), indx(3)
REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), &
- & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr
+ xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr
+
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = 3
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Hexahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
+ ! coeff = LagrangeCoeff_Hexahedron(&
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff, nrow=indx(1), ncol=indx(2))
END IF
- coeff0 = coeff
+ coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2)
+
ELSE
- coeff0 = LagrangeCoeff_Hexahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
+
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=indx(1), &
+ ncol=indx(2))
+
END IF
SELECT CASE (basisType0)
CASE (Monomial)
+
degree = LagrangeDegree_Hexahedron(order=order)
- tdof = SIZE(xij, 2)
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Hexahedron1", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+
+ IF (dim2 .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Hexahedron1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
- DO ii = 1, tdof
+#endif
+
+ DO ii = 1, dim2
d1 = degree(ii, 1)
d2 = degree(ii, 2)
d3 = degree(ii, 3)
@@ -2674,140 +2746,156 @@
DO ii = 1, 3
! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
- ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0)
+ ans(1:dim1, 1:dim2, ii) = MATMUL(xx(:, :, ii), coeff0)
END DO
-END PROCEDURE LagrangeGradientEvalAll_Hexahedron1
+END PROCEDURE LagrangeGradientEvalAll_Hexahedron1_
!----------------------------------------------------------------------------
! TensorProdBasisGradient_Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2)), z(SIZE(xij, 2))
-REAL(DFP) :: P1(SIZE(xij, 2), p + 1)
-REAL(DFP) :: Q1(SIZE(xij, 2), q + 1)
-REAL(DFP) :: R1(SIZE(xij, 2), r + 1)
-REAL(DFP) :: dP1(SIZE(xij, 2), p + 1)
-REAL(DFP) :: dQ1(SIZE(xij, 2), q + 1)
-REAL(DFP) :: dR1(SIZE(xij, 2), r + 1)
-
-INTEGER(I4B) :: ii, k1, k2, k3, cnt
-
-x = xij(1, :)
-y = xij(2, :)
-z = xij(3, :)
-
-P1 = BasisEvalAll_Line( &
- & order=p, &
- & x=x, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-Q1 = BasisEvalAll_Line( &
- & order=q, &
- & x=y, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-
-R1 = BasisEvalAll_Line( &
- & order=r, &
- & x=z, &
- & refLine="BIUNIT", &
- & basisType=basisType3, &
- & alpha=alpha3, &
- & beta=beta3, &
- & lambda=lambda3)
-
-dP1 = BasisGradientEvalAll_Line( &
- & order=p, &
- & x=x, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-dQ1 = BasisGradientEvalAll_Line( &
- & order=q, &
- & x=y, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-
-dR1 = BasisGradientEvalAll_Line( &
- & order=r, &
- & x=z, &
- & refLine="BIUNIT", &
- & basisType=basisType3, &
- & alpha=alpha3, &
- & beta=beta3, &
- & lambda=lambda3)
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL TensorProdBasisGradient_Hexahedron1_(p, q, r, xij, &
+ basisType1, basisType2, basisType3, ans, dim1, dim2, dim3, &
+ alpha1, beta1, lambda1, alpha2, beta2, lambda2, &
+ alpha3, beta3, lambda3)
+END PROCEDURE TensorProdBasisGradient_Hexahedron1
-cnt = 0
+!----------------------------------------------------------------------------
+! TensorProdBasisGradient_Hexahedron
+!----------------------------------------------------------------------------
-DO k3 = 1, r + 1
- DO k2 = 1, q + 1
- DO k1 = 1, p + 1
- cnt = cnt + 1
- ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2) * R1(:, k3)
- ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2) * R1(:, k3)
- ans(:, cnt, 3) = P1(:, k1) * Q1(:, k2) * dR1(:, k3)
- END DO
- END DO
+MODULE PROCEDURE TensorProdBasisGradient_Hexahedron1_
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+INTEGER(I4B) :: ii, k1, k2, k3, p1, q1, r1, o(6)
+
+p1 = p + 1
+q1 = q + 1
+r1 = r + 1
+
+dim1 = SIZE(xij, 2)
+dim2 = p1 * q1 * r1
+dim3 = 3
+
+ii = 2 * dim2
+ALLOCATE (temp(dim1, ii))
+
+o(1) = 0
+o(2) = o(1) + p1
+o(3) = o(2) + q1
+o(4) = o(3) + r1
+o(5) = o(4) + p1
+o(6) = o(5) + q1
+
+k1 = 1
+CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, &
+ ans=temp(1:, 1:), nrow=ii, ncol=k2)
+k1 = k1 + k2
+
+CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", &
+ basisType=basisType2, alpha=alpha2, beta=beta2, lambda=lambda2, &
+ ans=temp(1:, k1:), nrow=ii, ncol=k2)
+k1 = k1 + k2
+
+CALL BasisEvalAll_Line_(order=r, x=xij(3, :), refLine="BIUNIT", &
+ basisType=basisType3, alpha=alpha3, beta=beta3, lambda=lambda3, &
+ ans=temp(1:, k1:), nrow=ii, ncol=k2)
+k1 = k1 + k2
+
+CALL BasisGradientEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, &
+ ans=temp(1:, k1:), nrow=ii, ncol=k2)
+k1 = k1 + k2
+
+CALL BasisGradientEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", &
+ basisType=basisType2, alpha=alpha2, beta=beta2, lambda=lambda2, &
+ ans=temp(1:, k1:), nrow=ii, ncol=k2)
+k1 = k1 + k2
+
+CALL BasisGradientEvalAll_Line_(order=r, x=xij(3, :), refLine="BIUNIT", &
+ basisType=basisType3, alpha=alpha3, beta=beta3, lambda=lambda3, &
+ ans=temp(1:, k1:), nrow=ii, ncol=k2)
+k1 = k1 + k2
+
+DO CONCURRENT(ii=1:dim1, k1=1:p1, k2=1:q1, k3=1:r1)
+ ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1), 1) = &
+ temp(ii, o(4) + k1) * temp(ii, o(2) + k2) * temp(ii, o(3) + k3)
+
+ ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1), 2) = &
+ temp(ii, o(1) + k1) * temp(ii, o(5) + k2) * temp(ii, o(2) + k3)
+
+ ans(ii, k1 + p1 * (k2 - 1) + p1 * q1 * (k3 - 1), 3) = &
+ temp(ii, o(1) + k1) * temp(ii, o(2) + k2) * temp(ii, o(6) + k3)
END DO
-END PROCEDURE TensorProdBasisGradient_Hexahedron1
+
+DEALLOCATE (temp)
+
+END PROCEDURE TensorProdBasisGradient_Hexahedron1_
!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Hexahedron1
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron1
-#define _maxP_ MAXVAL([pb1, px1, px2, px3, px4, pxy1, pxz1])
-#define _maxQ_ MAXVAL([pb2, py1, py2, py3, py4, pxy2, pyz1])
-#define _maxR_ MAXVAL([pb3, pz1, pz2, pz3, pz4, pxz2, pyz2])
-
-INTEGER(I4B) :: a, b, maxP, maxQ, maxR
-REAL(DFP) :: L1(1:SIZE(xij, 2), 0:_maxP_)
-REAL(DFP) :: L2(1:SIZE(xij, 2), 0:_maxQ_)
-REAL(DFP) :: L3(1:SIZE(xij, 2), 0:_maxR_)
-REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:_maxP_)
-REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:_maxQ_)
-REAL(DFP) :: dL3(1:SIZE(xij, 2), 0:_maxR_)
-
-#undef _maxP_
-#undef _maxQ_
-#undef _maxR_
-
-maxP = SIZE(L1, 2) - 1
-maxQ = SIZE(L2, 2) - 1
-maxR = SIZE(L3, 2) - 1
-
-L1 = LobattoEvalAll(n=maxP, x=xij(1, :))
-L2 = LobattoEvalAll(n=maxQ, x=xij(2, :))
-L3 = LobattoEvalAll(n=maxR, x=xij(3, :))
-
-dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :))
-dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :))
-dL3 = LobattoGradientEvalAll(n=maxR, x=xij(3, :))
+INTEGER(I4B) :: dim1, dim2, dim3
+
+CALL HeirarchicalBasisGradient_Hexahedron1_(pb1=pb1, pb2=pb2, pb3=pb3, &
+ pxy1=pxy1, pxy2=pxy2, pxz1=pxz1, pxz2=pxz2, pyz1=pyz1, pyz2=pyz2, px1=px1, &
+ px2=px2, px3=px3, px4=px4, py1=py1, py2=py2, py3=py3, py4=py4, pz1=pz1, &
+ pz2=pz2, pz3=pz3, pz4=pz4, xij=xij, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3)
+END PROCEDURE HeirarchicalBasisGradient_Hexahedron1
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Hexahedron1
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron1_
+INTEGER(I4B) :: a, b, maxP, maxQ, maxR, indx(2)
+REAL( DFP ), ALLOCATABLE :: L1(:,:), L2(:,:), L3(:,:), dL1(:,:), dL2(:,:), &
+ dL3(:, :)
+
+dim1 = SIZE(xij, 2)
+
+dim2 = 8_I4B + (pb1 - 1_I4B) * (pb2 - 1_I4B) * (pb3 - 1_I4B) &
+ + (pxy1 - 1_I4B) * (pxy2 - 1_I4B) * 2_I4B &
+ + (pxz1 - 1_I4B) * (pxz2 - 1_I4B) * 2_I4B &
+ + (pyz1 - 1_I4B) * (pyz2 - 1_I4B) * 2_I4B &
+ + (px1 + px2 + px3 + px4 - 4_I4B) &
+ + (py1 + py2 + py3 + py4 - 4_I4B) &
+ + (pz1 + pz2 + pz3 + pz4 - 4_I4B)
+
+dim3 = 3_I4B
+
+maxP = MAX(pb1, px1, px2, px3, px4, pxy1, pxz1)
+maxQ = MAX(pb2, py1, py2, py3, py4, pxy2, pyz1)
+maxR = MAX(pb3, pz1, pz2, pz3, pz4, pxz2, pyz2)
+
+ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), L3(1:dim1, 0:maxR), &
+ dL1(1:dim1, 0:maxP), dL2(1:dim1, 0:maxQ), dL3(1:dim1, 0:maxR))
+
+CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2))
+CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2))
+CALL LobattoEvalAll_(n=maxR, x=xij(3, :), ans=L3, nrow=indx(1), ncol=indx(2))
+
+! dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :))
+CALL LobattoGradientEvalAll_(n=maxP, x=xij(1, :), ans=dL1, nrow=indx(1), &
+ ncol=indx(2))
+
+! dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :))
+CALL LobattoGradientEvalAll_(n=maxQ, x=xij(2, :), ans=dL2, nrow=indx(1), &
+ ncol=indx(2))
+
+! dL3 = LobattoGradientEvalAll(n=maxR, x=xij(3, :))
+CALL LobattoGradientEvalAll_(n=maxR, x=xij(3, :), ans=dL3, nrow=indx(1), &
+ ncol=indx(2))
! Vertex basis function
-ans(:, 1:8, :) = VertexBasisGradient_Hexahedron2( &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ans(1:dim1, 1:8, 1:dim3) = VertexBasisGradient_Hexahedron2(L1=L1, L2=L2, &
+ L3=L3, dL1=dL1, dL2=dL2, dL3=dL3)
! Edge basis function
b = 8
@@ -2815,52 +2903,25 @@
IF (ANY([px1, px2, px3, px4] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + px1 + px2 + px3 + px4 - 4
- ans(:, a:b, :) = xEdgeBasisGradient_Hexahedron2( &
- & pe1=px1, &
- & pe2=px2, &
- & pe3=px3, &
- & pe4=px4, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = xEdgeBasisGradient_Hexahedron2(pe1=px1, &
+ pe2=px2, pe3=px3, pe4=px4, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, &
+ dL3=dL3)
END IF
IF (ANY([py1, py2, py3, py4] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + py1 + py2 + py3 + py4 - 4
- ans(:, a:b, :) = yEdgeBasisGradient_Hexahedron2( &
- & pe1=py1, &
- & pe2=py2, &
- & pe3=py3, &
- & pe4=py4, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = yEdgeBasisGradient_Hexahedron2(pe1=py1, &
+ pe2=py2, pe3=py3, pe4=py4, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, &
+ dL3=dL3)
END IF
IF (ANY([pz1, pz2, pz3, pz4] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + pz1 + pz2 + pz3 + pz4 - 4
- ans(:, a:b, :) = zEdgeBasisGradient_Hexahedron2( &
- & pe1=pz1, &
- & pe2=pz2, &
- & pe3=pz3, &
- & pe4=pz4, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = zEdgeBasisGradient_Hexahedron2(pe1=pz1, &
+ pe2=pz2, pe3=pz3, pe4=pz4, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, &
+ dL3=dL3)
END IF
! Facet basis function
@@ -2868,83 +2929,84 @@
IF (ANY([pxy1, pxy2] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + 2 * (pxy1 - 1) * (pxy2 - 1)
- ans(:, a:b, :) = xyFacetBasisGradient_Hexahedron2( &
- & n1=pxy1, &
- & n2=pxy2, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = xyFacetBasisGradient_Hexahedron2(n1=pxy1, &
+ n2=pxy2, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3)
END IF
-IF (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN
+IF &
+ (ANY([pxz1, pxz2] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + 2 * (pxz1 - 1) * (pxz2 - 1)
- ans(:, a:b, :) = xzFacetBasisGradient_Hexahedron2( &
- & n1=pxz1, &
- & n2=pxz2, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = xzFacetBasisGradient_Hexahedron2(n1=pxz1, &
+ n2=pxz2, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3)
END IF
IF (ANY([pyz1, pyz2] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + 2 * (pyz1 - 1) * (pyz2 - 1)
- ans(:, a:b, :) = yzFacetBasisGradient_Hexahedron2( &
- & n1=pyz1, &
- & n2=pyz2, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = yzFacetBasisGradient_Hexahedron2(n1=pyz1, &
+ n2=pyz2, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3)
END IF
IF (ANY([pb1, pb2, pb3] .GE. 2_I4B)) THEN
a = b + 1
b = a - 1 + (pb1 - 1) * (pb2 - 1) * (pb3 - 1)
- ans(:, a:b, :) = cellBasisGradient_Hexahedron2( &
- & n1=pb1, &
- & n2=pb2, &
- & n3=pb3, &
- & L1=L1, &
- & L2=L2, &
- & L3=L3, &
- & dL1=dL1, &
- & dL2=dL2, &
- & dL3=dL3 &
- & )
+ ans(1:dim1, a:b, 1:dim3) = cellBasisGradient_Hexahedron2(n1=pb1, n2=pb2, &
+ n3=pb3, L1=L1, L2=L2, L3=L3, dL1=dL1, dL2=dL2, dL3=dL3)
END IF
-END PROCEDURE HeirarchicalBasisGradient_Hexahedron1
+END PROCEDURE HeirarchicalBasisGradient_Hexahedron1_
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Hexahedron2
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron2
-ans = HeirarchicalBasisGradient_Hexahedron1(&
- & pb1=p, pb2=q, pb3=r, &
- & pxy1=p, pxy2=q, &
- & pxz1=p, pxz2=r, &
- & pyz1=q, pyz2=r, &
- & px1=p, px2=p, px3=p, px4=p, &
- & py1=q, py2=q, py3=q, py4=q, &
- & pz1=r, pz2=r, pz3=r, pz4=r, &
- & xij=xij)
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL HeirarchicalBasisGradient_Hexahedron2_(p=p, q=q, r=r, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
END PROCEDURE HeirarchicalBasisGradient_Hexahedron2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+MODULE PROCEDURE HeirarchicalBasisGradient_Hexahedron2_
+CALL HeirarchicalBasisGradient_Hexahedron1_(pb1=p, pb2=q, pb3=r, pxy1=p, &
+ pxy2=q, pxz1=p, pxz2=r, pyz1=q, pyz2=r, px1=p, px2=p, px3=p, px4=p, py1=q, &
+ py2=q, py3=q, py4=q, pz1=r, pz2=r, pz3=r, pz4=r, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE HeirarchicalBasisGradient_Hexahedron2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Hexahedron1_
+CALL ErrorMsg(&
+ & msg="InterpolationPoint_Hexahedron1_ is not implemented", &
+ & file=__FILE__, &
+ & routine="InterpolationPoint_Hexahedron1_", &
+ & line=__LINE__, &
+ & unitno=stderr)
+! STOP
+END PROCEDURE InterpolationPoint_Hexahedron1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Hexahedron2_
+CALL ErrorMsg(&
+ & msg="InterpolationPoint_Hexahedron2_ is not implemented", &
+ & file=__FILE__, &
+ & routine="InterpolationPoint_Hexahedron2_", &
+ & line=__LINE__, &
+ & unitno=stderr)
+STOP
+END PROCEDURE InterpolationPoint_Hexahedron2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90
new file mode 100644
index 000000000..462fefdbf
--- /dev/null
+++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90
@@ -0,0 +1,598 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.com
+! Vikas Sharma, Ph.D., vickysharma0812@gmail.com
+!
+! 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(HierarchicalPolynomialUtility) Methods
+USE GlobalData, ONLY: stderr
+
+USE ReferenceElement_Method, ONLY: XiDimension, &
+ GetTotalNodes, &
+ ElementTopology, &
+ GetTotalEdges
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE BaseType, ONLY: elemopt => TypeElemNameOpt
+
+USE LineInterpolationUtility, ONLY: HeirarchicalBasis_Line_, &
+ HeirarchicalBasisGradient_Line_, &
+ GetTotalInDOF_Line
+
+USE TriangleInterpolationUtility, ONLY: HeirarchicalBasis_Triangle_, &
+ HeirarchicalBasisGradient_Triangle_, &
+ GetTotalInDOF_Triangle
+
+USE QuadrangleInterpolationUtility, ONLY: HeirarchicalBasis_Quadrangle_, &
+ HeirarchicalBasisGradient_Quadrangle_, &
+ GetTotalInDOF_Quadrangle
+
+USE TetrahedronInterpolationUtility, ONLY: HeirarchicalBasis_Tetrahedron_, &
+ HeirarchicalBasisGradient_Tetrahedron_, &
+ GetTotalInDOF_Tetrahedron
+
+USE HexahedronInterpolationUtility, ONLY: HeirarchicalBasis_Hexahedron_, &
+ HeirarchicalBasisGradient_Hexahedron_, &
+ GetTotalInDOF_Hexahedron
+
+USE PrismInterpolationUtility, ONLY: GetTotalInDOF_Prism
+
+USE PyramidInterpolationUtility, ONLY: GetTotalInDOF_Pyramid
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalDOF
+INTEGER(I4B) :: ii
+
+ans = 0
+
+ii = HierarchicalVertexDOF(elemType=elemType)
+ans = ans + ii
+
+IF (PRESENT(cellOrder)) THEN
+ ii = HierarchicalCellDOF(elemType=elemType, order=cellOrder)
+ ans = ans + ii
+END IF
+
+IF (PRESENT(faceOrder)) THEN
+ ii = HierarchicalFaceDOF(elemType=elemType, order=faceOrder)
+ ans = ans + ii
+END IF
+
+IF (PRESENT(edgeOrder)) THEN
+ ii = HierarchicalEdgeDOF(elemType=elemType, order=edgeOrder)
+ ans = ans + ii
+END IF
+
+END PROCEDURE HierarchicalDOF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalVertexDOF
+ans = GetTotalNodes(elemType)
+END PROCEDURE HierarchicalVertexDOF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalEdgeDOF
+INTEGER(I4B) :: topo, ii, tedges
+
+topo = ElementTopology(elemType)
+ans = 0
+
+SELECT CASE (topo)
+CASE (elemopt%Tetrahedron, elemopt%Hexahedron, elemopt%Prism, elemopt%Pyramid)
+
+ tedges = GetTotalEdges(topo)
+
+ DO ii = 1, tedges
+ ans = ans + GetTotalInDOF_Line(order=order(ii), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+ END DO
+
+END SELECT
+
+END PROCEDURE HierarchicalEdgeDOF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalFaceDOF
+INTEGER(I4B) :: topo, jj, ii
+
+topo = ElementTopology(elemType)
+
+ans = 0
+
+SELECT CASE (topo)
+CASE (elemopt%Point)
+ ans = 0
+
+CASE (elemopt%Line)
+ ans = 0
+
+CASE (elemopt%Triangle)
+ DO ii = 1, 3
+ jj = GetTotalInDOF_Line(order=order(1, ii), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+ ans = ans + jj
+ END DO
+
+CASE (elemopt%Quadrangle)
+ DO ii = 1, 4
+ jj = GetTotalInDOF_Line(order=order(1, ii), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+ ans = ans + jj
+ END DO
+
+CASE (elemopt%Tetrahedron)
+ DO ii = 1, 4
+ jj = GetTotalInDOF_Triangle(order=order(1, ii), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+ ans = ans + jj
+ END DO
+
+CASE (elemopt%Hexahedron)
+ DO ii = 1, 6
+ jj = GetTotalInDOF_Quadrangle(p=order(1, ii), q=order(2, ii), &
+ baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+ ans = ans + jj
+ END DO
+
+! CASE (elemopt%Prism)
+! CASE (elemopt%Pyramid)
+END SELECT
+END PROCEDURE HierarchicalFaceDOF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalCellDOF
+INTEGER(I4B) :: topo
+
+ans = 0
+topo = ElementTopology(elemType)
+SELECT CASE (topo)
+CASE (elemopt%Point)
+ ans = 0
+CASE (elemopt%Line)
+ ans = GetTotalInDOF_Line(order=order(1), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+CASE (elemopt%Triangle)
+ ans = GetTotalInDOF_Triangle(order=order(1), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+CASE (elemopt%Quadrangle)
+ ans = GetTotalInDOF_Quadrangle(p=order(1), q=order(2), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+CASE (elemopt%Tetrahedron)
+ ans = GetTotalInDOF_Tetrahedron(order=order(1), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+
+CASE (elemopt%Hexahedron)
+ ans = GetTotalInDOF_Hexahedron(p=order(1), q=order(2), r=order(3), &
+ baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+
+CASE (elemopt%Prism)
+ ans = GetTotalInDOF_Prism(order=order(1), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+CASE (elemopt%Pyramid)
+
+ ans = GetTotalInDOF_Pyramid(order=order(1), baseContinuity="H1", &
+ baseInterpolation="HEIRARCHICAL")
+END SELECT
+END PROCEDURE HierarchicalCellDOF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalEvalAll
+INTEGER(I4B) :: nrow, ncol
+
+nrow = SIZE(xij, 2)
+ncol = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, &
+ faceOrder=faceOrder, edgeOrder=edgeOrder)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL HierarchicalEvalAll_(elemType=elemType, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol, domainName=domainName, cellOrder=cellOrder, &
+ faceOrder=faceOrder, edgeOrder=edgeOrder, cellOrient=cellOrient, &
+ faceOrient=faceOrient, edgeOrient=edgeOrient)
+
+END PROCEDURE HierarchicalEvalAll
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalEvalAll_
+#ifdef DEBUG_VER
+INTEGER(I4B) :: ierr
+CHARACTER(*), PARAMETER :: routine = "HierarchicalEvalAll_()"
+#endif
+
+INTEGER(I4B) :: topo
+
+nrow = 0; ncol = 0
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+
+CASE (elemopt%Line)
+
+#ifdef DEBUG_VER
+ CALL check_error_1d(ierr=ierr, routine=routine, &
+ cellOrder=cellOrder, cellOrient=cellOrient)
+
+ IF (ierr .LT. 0) RETURN
+#endif
+
+ CALL HeirarchicalBasis_Line_(order=cellOrder(1), xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol, refLine=domainName, orient=cellOrient(1))
+
+CASE (elemopt%Triangle)
+
+#ifdef DEBUG_VER
+ CALL check_error_2d(ierr=ierr, tface=3, routine=routine, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+ IF (ierr .LT. 0) RETURN
+#endif
+
+ CALL HeirarchicalBasis_Triangle_(order=cellOrder(1), &
+ pe1=faceOrder(1, 1), &
+ pe2=faceOrder(1, 2), &
+ pe3=faceOrder(1, 3), &
+ xij=xij, &
+ refTriangle=domainName, &
+ ans=ans, nrow=nrow, ncol=ncol, &
+ edgeOrient1=faceOrient(1, 1), &
+ edgeOrient2=faceOrient(1, 2), &
+ edgeOrient3=faceOrient(1, 3), &
+ faceOrient=cellOrient)
+
+CASE (elemopt%Quadrangle)
+
+#ifdef DEBUG_VER
+ CALL check_error_2d(ierr=ierr, tface=4, routine=routine, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+ IF (ierr .LT. 0) RETURN
+#endif
+
+ CALL HeirarchicalBasis_Quadrangle_(pb=cellOrder(1), &
+ qb=cellOrder(2), &
+ pe3=faceOrder(1, 1), &
+ pe4=faceOrder(1, 3), &
+ qe1=faceOrder(1, 4), &
+ qe2=faceOrder(1, 2), &
+ xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, &
+ pe3Orient=faceOrient(1, 1), &
+ pe4Orient=faceOrient(1, 3), &
+ qe1Orient=faceOrient(1, 4), &
+ qe2Orient=faceOrient(1, 2), &
+ faceOrient=cellOrient)
+
+! CASE (elemopt%Tetrahedron)
+
+! CALL HeirarchicalBasis_Tetrahedron_(order=cellOrder(1), pe1=edgeOrder(1), &
+! pe2=edgeOrder(2), pe3=edgeOrder(3), pe4=edgeOrder(4), pe5=edgeOrder(5), &
+! pe6=edgeOrder(6), ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), &
+! ps3=faceOrder(1, 3), ps4=faceOrder(1, 4), xij=xij, &
+! refTetrahedron=domainName, ans=ans, &
+! nrow=nrow, ncol=ncol)
+
+! CASE (elemopt%Hexahedron)
+
+! CALL HeirarchicalBasis_Hexahedron_( &
+! pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), &
+! pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), &
+! pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), &
+! pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), &
+! px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), &
+! py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), &
+! pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), &
+! pz4=edgeOrder(12), xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+
+! CASE (elemopt%Prism)
+
+! CASE (elemopt%Pyramid)
+
+CASE DEFAULT
+ CALL ErrorMsg(msg="No case found for topology", &
+ routine='HierarchicalEvalAll_()', &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ RETURN
+END SELECT
+
+END PROCEDURE HierarchicalEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalGradientEvalAll
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = SIZE(xij, 2)
+dim2 = HierarchicalDOF(elemType=elemType, cellOrder=cellOrder, &
+ faceOrder=faceOrder, edgeOrder=edgeOrder)
+dim3 = XiDimension(elemType)
+
+ALLOCATE (ans(dim1, dim2, dim3))
+
+CALL HierarchicalGradientEvalAll_(elemType=elemType, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, domainName=domainName, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+END PROCEDURE HierarchicalGradientEvalAll
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalGradientEvalAll_
+#ifdef DEBUG_VER
+INTEGER(I4B) :: ierr
+CHARACTER(*), PARAMETER :: routine = "HierarchicalGradientEvalAll_()"
+#endif
+
+INTEGER(I4B) :: topo
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+
+CASE (elemopt%Line)
+
+#ifdef DEBUG_VER
+ CALL check_error_1d(ierr=ierr, routine=routine, cellOrder=cellOrder, &
+ cellOrient=cellOrient)
+
+ IF (ierr .LT. 0) RETURN
+#endif
+
+ CALL HeirarchicalBasisGradient_Line_(order=cellOrder(1), xij=xij, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3, refLine=domainName, orient=cellOrient(1))
+
+CASE (elemopt%Triangle)
+
+#ifdef DEBUG_VER
+ CALL check_error_2d(ierr=ierr, tface=3, routine=routine, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+ IF (ierr .LT. 0) RETURN
+#endif
+
+ CALL HeirarchicalBasisGradient_Triangle_(order=cellOrder(1), &
+ pe1=faceOrder(1, 1), &
+ pe2=faceOrder(1, 2), &
+ pe3=faceOrder(1, 3), &
+ xij=xij, &
+ refTriangle=domainName, &
+ ans=ans, tsize1=dim1, &
+ tsize2=dim2, tsize3=dim3, &
+ edgeOrient1=faceOrient(1, 1), &
+ edgeOrient2=faceOrient(1, 2), &
+ edgeOrient3=faceOrient(1, 3), &
+ faceOrient=cellOrient)
+
+CASE (elemopt%Quadrangle)
+
+#ifdef DEBUG_VER
+ CALL check_error_2d(ierr=ierr, tface=4, routine=routine, &
+ cellOrder=cellOrder, faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, edgeOrient=edgeOrient)
+ IF (ierr .LT. 0) RETURN
+#endif
+
+ CALL HeirarchicalBasisGradient_Quadrangle_(pb=cellOrder(1), &
+ qb=cellOrder(2), &
+ pe3=faceOrder(1, 1), &
+ qe2=faceOrder(1, 2), &
+ pe4=faceOrder(1, 3), &
+ qe1=faceOrder(1, 4), &
+ xij=xij, &
+ ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3, &
+ pe3Orient=faceOrient(1, 1), &
+ qe2Orient=faceOrient(1, 2), &
+ pe4Orient=faceOrient(1, 3), &
+ qe1Orient=faceOrient(1, 4), &
+ faceOrient=cellOrient)
+
+! CASE (elemopt%Tetrahedron)
+
+ ! CALL HeirarchicalBasisGradient_Tetrahedron_(order=cellOrder(1), &
+ ! pe1=edgeOrder(1), pe2=edgeOrder(2), pe3=edgeOrder(3), &
+ ! pe4=edgeOrder(4), pe5=edgeOrder(5), pe6=edgeOrder(6), &
+ ! ps1=faceOrder(1, 1), ps2=faceOrder(1, 2), ps3=faceOrder(1, 3), &
+ ! ps4=faceOrder(1, 4), xij=xij, refTetrahedron=domainName, &
+ ! ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+! CASE (elemopt%Hexahedron)
+
+ ! CALL HeirarchicalBasisGradient_Hexahedron_( &
+ ! pb1=cellOrder(1), pb2=cellOrder(2), pb3=cellOrder(3), &
+ ! pxy1=faceOrder(1, 1), pxy2=faceOrder(2, 1), &
+ ! pxz1=faceOrder(1, 2), pxz2=faceOrder(2, 2), &
+ ! pyz1=faceOrder(1, 3), pyz2=faceOrder(2, 3), &
+ ! px1=edgeOrder(1), px2=edgeOrder(2), px3=edgeOrder(3), px4=edgeOrder(4), &
+ ! py1=edgeOrder(5), py2=edgeOrder(6), py3=edgeOrder(7), py4=edgeOrder(8), &
+ ! pz1=edgeOrder(9), pz2=edgeOrder(10), pz3=edgeOrder(11), &
+ ! pz4=edgeOrder(12), xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+! CASE (elemopt%Prism)
+
+! CASE (elemopt%Pyramid)
+
+CASE DEFAULT
+ CALL ErrorMsg(msg="No case found for topology", &
+ routine='HierarchicalEvalAll_()', &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ RETURN
+END SELECT
+
+END PROCEDURE HierarchicalGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE check_error_1d(ierr, routine, cellOrder, cellOrient)
+ INTEGER(I4B), INTENT(OUT) :: ierr
+ CHARACTER(*), INTENT(IN) :: routine
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+
+ ! internal variables
+ LOGICAL(LGT) :: isok
+ CHARACTER(:), ALLOCATABLE :: errmsg
+
+ ierr = 0
+ isok = PRESENT(cellOrder)
+ IF (.NOT. isok) THEN
+ ierr = -1
+ errmsg = "cellOrder is not present"
+ END IF
+
+ isok = PRESENT(cellOrient)
+ IF (.NOT. isok) THEN
+ ierr = -2
+ errmsg = "cellOrient is not present"
+ END IF
+
+ IF (.NOT. isok) THEN
+ CALL ErrorMsg(msg=errmsg, routine=routine, file=__FILE__, &
+ line=__LINE__, unitno=stderr)
+ RETURN
+ END IF
+
+END SUBROUTINE check_error_1d
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE check_error_2d(ierr, tface, routine, cellOrder, &
+ faceOrder, edgeOrder, cellOrient, faceOrient, edgeOrient)
+ INTEGER(I4B), INTENT(OUT) :: ierr
+ INTEGER(I4B), INTENT(IN) :: tface
+ CHARACTER(*), INTENT(IN) :: routine
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrder(:)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrder(:, :)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrder(:)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: cellOrient(:)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: faceOrient(:, :)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: edgeOrient(:)
+
+ LOGICAL(LGT) :: isok
+ CHARACTER(:), ALLOCATABLE :: errmsg
+
+ ierr = 0
+
+ isok = PRESENT(cellOrder)
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "cellOrder is not present"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = PRESENT(cellOrient)
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "cellOrient is not present"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = PRESENT(faceOrder)
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "faceOrder is not present"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = SIZE(faceOrder, 2) .GE. tface
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "colsize of faceOrder should be at least total face in elements"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = SIZE(faceOrder, 1) .GE. 3_I4B
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "rowsize of faceOrder should be at least 3"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = PRESENT(faceOrient)
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "faceOrient is not present"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = SIZE(faceOrient, 1) .GE. 3
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "rowsize of faceOrient should be at least 3"
+ CALL print_error
+ RETURN
+ END IF
+
+ isok = SIZE(faceOrient, 2) .GE. tface
+ IF (.NOT. isok) THEN
+ ierr = ierr - 1
+ errmsg = "colsize of faceOrient should be at least total face in elements"
+ CALL print_error
+ RETURN
+ END IF
+
+CONTAINS
+ SUBROUTINE print_error
+ CALL ErrorMsg(msg=errmsg, routine=routine, file=__FILE__, &
+ line=__LINE__, unitno=stderr)
+ END SUBROUTINE print_error
+
+END SUBROUTINE check_error_2d
+
+END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90
index 93e179fd5..53351e70a 100644
--- a/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/InterpolationUtility@Methods.F90
@@ -20,20 +20,34 @@
Tetrahedron, Hexahedron, Prism, Pyramid
USE ReferenceElement_Method, ONLY: ElementTopology
+
USE LineInterpolationUtility, ONLY: GetTotalDOF_Line, &
- GetTotalInDOF_Line
+ GetTotalInDOF_Line, &
+ RefElemDomain_Line
+
USE TriangleInterpolationUtility, ONLY: GetTotalDOF_Triangle, &
- GetTotalInDOF_Triangle
+ GetTotalInDOF_Triangle, &
+ RefElemDomain_Triangle
+
USE QuadrangleInterpolationUtility, ONLY: GetTotalDOF_Quadrangle, &
- GetTotalInDOF_Quadrangle
+ GetTotalInDOF_Quadrangle, &
+ RefElemDomain_Quadrangle
+
USE TetrahedronInterpolationUtility, ONLY: GetTotalDOF_Tetrahedron, &
- GetTotalInDOF_Tetrahedron
+ GetTotalInDOF_Tetrahedron, &
+ RefElemDomain_Tetrahedron
+
USE HexahedronInterpolationUtility, ONLY: GetTotalDOF_Hexahedron, &
- GetTotalInDOF_Hexahedron
+ GetTotalInDOF_Hexahedron, &
+ RefElemDomain_Hexahedron
+
USE PrismInterpolationUtility, ONLY: GetTotalDOF_Prism, &
- GetTotalInDOF_Prism
+ GetTotalInDOF_Prism, &
+ RefElemDomain_Prism
+
USE PyramidInterpolationUtility, ONLY: GetTotalDOF_Pyramid, &
- GetTotalInDOF_Pyramid
+ GetTotalInDOF_Pyramid, &
+ RefElemDomain_Pyramid
IMPLICIT NONE
CONTAINS
@@ -146,4 +160,41 @@
END PROCEDURE GetTotalInDOF1
+!----------------------------------------------------------------------------
+! RefElemDomain
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RefElemDomain
+INTEGER(I4B) :: topo
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+CASE (Point)
+ ans = ""
+
+CASE (Line)
+ ans = RefElemDomain_Line(baseContinuity, baseInterpol)
+
+CASE (Triangle)
+ ans = RefElemDomain_Triangle(baseContinuity, baseInterpol)
+
+CASE (Quadrangle)
+ ans = RefElemDomain_Quadrangle(baseContinuity, baseInterpol)
+
+CASE (Tetrahedron)
+ ans = RefElemDomain_Tetrahedron(baseContinuity, baseInterpol)
+
+CASE (Hexahedron)
+ ans = RefElemDomain_Hexahedron(baseContinuity, baseInterpol)
+
+CASE (Prism)
+ ans = RefElemDomain_Prism(baseContinuity, baseInterpol)
+
+CASE (Pyramid)
+ ans = RefElemDomain_Pyramid(baseContinuity, baseInterpol)
+END SELECT
+
+END PROCEDURE RefElemDomain
+
END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90
index 676683b43..ac43e61c7 100644
--- a/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/JacobiPolynomialUtility@Methods.F90
@@ -16,7 +16,18 @@
!
SUBMODULE(JacobiPolynomialUtility) Methods
-USE BaseMethod
+USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix
+
+#ifdef USE_LAPACK95
+USE F95_Lapack, ONLY: STEV
+#endif
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE MiscUtility, ONLY: Factorial
+
+USE BaseType, ONLY: qp => TypeQuadratureOpt
+
IMPLICIT NONE
CONTAINS
@@ -120,11 +131,11 @@
!!
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));
+ 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));
+ & / (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));
+ & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2));
END DO
!!
END PROCEDURE GetJacobiRecurrenceCoeff2
@@ -436,19 +447,19 @@
REAL(DFP), PARAMETER :: left = -1.0_DFP, right = 1.0_DFP
!!
SELECT CASE (quadType)
-CASE (Gauss)
+CASE (qp%Gauss)
order = n
CALL JacobiGaussQuadrature(n=order, alpha=alpha, beta=beta, &
& pt=pt, wt=wt)
-CASE (GaussRadau, GaussRadauLeft)
+CASE (qp%GaussRadau, qp%GaussRadauLeft)
order = n - 1
CALL JacobiGaussRadauQuadrature(a=left, n=order, alpha=alpha, beta=beta, &
& pt=pt, wt=wt)
-CASE (GaussRadauRight)
+CASE (qp%GaussRadauRight)
order = n - 1
CALL JacobiGaussRadauQuadrature(a=right, n=order, alpha=alpha, beta=beta, &
& pt=pt, wt=wt)
-CASE (GaussLobatto)
+CASE (qp%GaussLobatto)
order = n - 2
CALL JacobiGaussLobattoQuadrature(n=order, alpha=alpha, beta=beta, &
& pt=pt, wt=wt)
@@ -460,117 +471,125 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE JacobiEvalAll1
+INTEGER(I4B) :: tsize
+CALL JacobiEvalAll1_(n=n, x=x, alpha=alpha, beta=beta, ans=ans, tsize=tsize)
+END PROCEDURE JacobiEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
-!!
+REAL(DFP) :: c1, c2, c3, c4, r_i, apb, amb, r2, apb_minus_2, apb_minus_1, &
+ alpha_minus_1, beta_minus_1
+
+tsize = 0
+
+IF (alpha <= -1.0_DFP) RETURN
+IF (beta <= -1.0_DFP) RETURN
+
+IF (n < 0) RETURN
+
+tsize = 1 + n
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)
-!!
+
+IF (n .EQ. 0) RETURN
+
+apb = alpha + beta
+apb_minus_2 = apb - 2.0_DFP
+apb_minus_1 = apb - 1.0_DFP
+alpha_minus_1 = alpha - 1.0_DFP
+beta_minus_1 = beta - 1.0_DFP
+amb = alpha - beta
+
+ans(2) = (1.0_DFP + 0.5_DFP * apb) * x + 0.5_DFP * amb
+
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
- !!
+
+ r_i = REAL(i, kind=DFP)
+ r2 = 2.0_DFP * r_i
+
+ c1 = r2 * (r_i + apb) * (r2 + apb_minus_2)
+
+ c2 = (r2 + apb_minus_1) * (r2 + apb) * (r2 + apb_minus_2)
+ c2 = c2 / c1
+
+ c3 = (r2 + apb_minus_1) * apb * amb
+ c3 = c3 / c1
+
+ c4 = -2.0_DFP * (r_i + alpha_minus_1) * (r_i + beta_minus_1) * (r2 + apb)
+
+ c4 = c4 / c1
+
+ ans(i + 1) = (c3 + c2 * x) * ans(i) + c4 * ans(i - 1)
+
END DO
-END PROCEDURE JacobiEvalAll1
+END PROCEDURE JacobiEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE JacobiEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL JacobiEvalAll2_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE JacobiEvalAll2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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)
-!!
+REAL(DFP) :: c1, c2, c3, c4, r_i, apb, amb, r2, apb_minus_2, apb_minus_1, &
+ alpha_minus_1, beta_minus_1
+
+nrow = 0
+ncol = 0
+IF (alpha <= -1.0_DFP) RETURN
+IF (beta <= -1.0_DFP) RETURN
+IF (n < 0) RETURN
+
+nrow = SIZE(x)
+ncol = 1 + n
+
+ans(1:nrow, 1) = 1.0_DFP
+
+IF (n .EQ. 0) RETURN
+
+apb = alpha + beta
+apb_minus_2 = apb - 2.0_DFP
+apb_minus_1 = apb - 1.0_DFP
+alpha_minus_1 = alpha - 1.0_DFP
+beta_minus_1 = beta - 1.0_DFP
+
+ans(1:nrow, 2) = (1.0_DFP + 0.5_DFP * apb) * x + 0.5_DFP * amb
+
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
- !!
+
+ r_i = REAL(i, kind=DFP)
+ r2 = 2.0_DFP * r_i
+
+ c1 = r2 * (r_i + apb) * (r2 + apb_minus_2)
+
+ c2 = (r2 + apb_minus_1) * (r2 + apb) * (r2 + apb_minus_2)
+ c2 = c2 / c1
+
+ c3 = (r2 + apb_minus_1) * apb * amb
+ c3 = c3 / c1
+
+ c4 = -2.0_DFP * (r_i + alpha_minus_1) * (r_i + beta_minus_1) * (r2 + apb)
+ c4 = c4 / c1
+
+ ans(1:nrow, i + 1) = (c3 + c2 * x) * ans(1:nrow, i) &
+ + c4 * ans(1:nrow, i - 1)
+
END DO
- !!
-END PROCEDURE JacobiEvalAll2
+
+END PROCEDURE JacobiEvalAll2_
!----------------------------------------------------------------------------
!
@@ -606,7 +625,7 @@
!!
DO i = 2, n
!!
- r_i = real(i, kind=DFP)
+ 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)
@@ -663,7 +682,7 @@
!!
DO i = 2, n
!!
- r_i = real(i, kind=DFP)
+ 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)
@@ -704,7 +723,7 @@
b2 = 0.0_DFP
!!
DO j = n, 0, -1
- t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j);
+ t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j);
b2 = b1
b1 = t
END DO
@@ -732,7 +751,7 @@
b2 = 0.0_DFP
!!
DO j = n, 0, -1
- t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j);
+ t = (A(j) * x + B(j)) * b1 - C(j + 1) * b2 + coeff(j);
b2 = b1
b1 = t
END DO
@@ -778,11 +797,11 @@
!!
p_1 = p
!!
- a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta));
+ 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));
+ & / (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));
+ & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2));
!!
p = (a1 * x + a2) * p - a3 * p_2
!!
@@ -838,11 +857,11 @@
!!
p_1 = p
!!
- a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta));
+ 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));
+ & / (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));
+ & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2));
!!
p = (a1 * x + a2) * p - a3 * p_2
!!
@@ -867,51 +886,58 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE JacobiGradientEvalAll1
-!!
+INTEGER(I4B) :: tsize
+CALL JacobiGradientEvalAll1_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, &
+ tsize=tsize)
+END PROCEDURE JacobiGradientEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
-!!
+
+tsize = 0
+
+IF (n < 0) RETURN
+
+tsize = n + 1
+
p(1) = 1.0_DFP
ans(1) = 0.0_DFP
-!!
-IF (n < 1) THEN
- RETURN
-END IF
-!!
-!!
+
+IF (n < 1) RETURN
+
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));
+
+ 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));
+ / (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));
- !!
+ / (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
+
+END PROCEDURE JacobiGradientEvalAll1_
!----------------------------------------------------------------------------
! JacobiGradientEvalAll
@@ -944,11 +970,11 @@
!!
j = REAL(ii, KIND=DFP)
!!
- a1 = (2*j+alpha+beta-1)*(2*j+alpha+beta)/(2*j*(j+alpha+beta));
+ 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));
+ & / (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));
+ & / (j * (j + alpha + beta) * (2 * j + alpha + beta - 2));
!!
p(:, ii + 1) = (a1 * x + a2) * p(:, ii) - a3 * p(:, ii - 1)
!!
@@ -963,6 +989,61 @@
!!
END PROCEDURE JacobiGradientEvalAll2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
+
+nrow = 0
+ncol = 0
+
+IF (n < 0) RETURN
+
+nrow = SIZE(x)
+ncol = 1 + n
+
+p(1:nrow, 1) = 1.0_DFP
+ans(1:nrow, 1) = 0.0_DFP
+
+IF (n < 1) RETURN
+
+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(1:nrow, ii + 1) = (a1 * x + a2) * p(1:nrow, ii) - a3 * p(1:nrow, 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(1:nrow, ii + 1) = p(1:nrow, ii) - b1 * ans(1:nrow, ii - 1) &
+ - b2 * ans(1:nrow, ii)
+
+ ans(1:nrow, ii + 1) = ans(1:nrow, ii + 1) / b3
+
+END DO
+
+END PROCEDURE JacobiGradientEvalAll2_
+
!----------------------------------------------------------------------------
! JacobiGradientEvalSum
!----------------------------------------------------------------------------
@@ -984,18 +1065,18 @@
!!
!! 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);
+ 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;
+ & / ((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
@@ -1024,18 +1105,18 @@
!!
!! 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);
+ 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;
+ & / ((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
@@ -1069,17 +1150,17 @@
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));
+ 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;
+ & / (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
@@ -1115,17 +1196,17 @@
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));
+ 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;
+ & / (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
@@ -1137,75 +1218,98 @@
!----------------------------------------------------------------------------
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
-!!
+INTEGER(I4B) :: tsize
+CALL JacobiTransform1_(n, alpha, beta, coeff, x, w, quadType, ans, tsize)
END PROCEDURE JacobiTransform1
+!----------------------------------------------------------------------------
+! JacobiTransform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE JacobiTransform1_
+REAL(DFP), ALLOCATABLE :: PP(:, :)
+INTEGER(I4B) :: ii, jj, nips
+nips = SIZE(coeff)
+ALLOCATE (PP(nips, n + 1))
+CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, nrow=ii, ncol=jj, &
+ ans=PP)
+CALL JacobiTransform4_(n, alpha, beta, coeff, PP, w, quadType, ans, tsize)
+DEALLOCATE (PP)
+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)
+MODULE PROCEDURE JacobiTransform4_
+REAL(DFP) :: nrmsqr, areal
+INTEGER(I4B) :: jj, ii, nips
+LOGICAL(LGT) :: abool
+
+tsize = n + 1
+
+nips = SIZE(coeff)
+
+DO jj = 0, n
+ areal = 0.0_DFP
+
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
END DO
+
+ nrmsqr = JacobiNormSQR(n=jj, alpha=alpha, beta=beta)
+ ans(jj) = areal / nrmsqr
+
END DO
-!!
-END PROCEDURE JacobiTransform2
+
+abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1)
+
+IF (abool) THEN
+
+ areal = 0.0_DFP
+ jj = n
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+
+ nrmsqr = (2.0_DFP + (alpha + beta + 1.0_DFP) / REAL(n, KIND=DFP)) * nrmsqr
+
+ ans(jj) = areal / nrmsqr
+
+END IF
+
+END PROCEDURE JacobiTransform4_
!----------------------------------------------------------------------------
! JacobiTransform
!----------------------------------------------------------------------------
MODULE PROCEDURE JacobiTransform3
-REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n)
+INTEGER(I4B) :: tsize
+CALL JacobiTransform3_(n, alpha, beta, f, quadType, x1, x2, ans, tsize)
+END PROCEDURE JacobiTransform3
+
+!----------------------------------------------------------------------------
+! JacobiTransform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE JacobiTransform3_
+REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x
+REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP
INTEGER(I4B) :: ii
-!!
-CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt,&
- & quadType=quadType)
-!!
+
+CALL JacobiQuadrature(n=n + 1, alpha=alpha, beta=beta, pt=pt, wt=wt, &
+ quadType=quadType)
+
DO ii = 0, n
- coeff(ii) = f(pt(ii))
+ x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2
+ x = x * half
+ coeff(ii) = f(x)
END DO
-!!
-ans = JacobiTransform(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, &
- & w=wt, quadType=quadType)
-END PROCEDURE JacobiTransform3
+
+CALL JacobiTransform_(n=n, alpha=alpha, beta=beta, coeff=coeff, x=pt, &
+ w=wt, quadType=quadType, ans=ans, tsize=tsize)
+END PROCEDURE JacobiTransform3_
!----------------------------------------------------------------------------
! JacobiInvTransform
@@ -1213,7 +1317,7 @@
MODULE PROCEDURE JacobiInvTransform1
ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, &
- & x=x)
+ x=x)
END PROCEDURE JacobiInvTransform1
!----------------------------------------------------------------------------
@@ -1222,7 +1326,7 @@
MODULE PROCEDURE JacobiInvTransform2
ans = JacobiEvalSum(n=n, alpha=alpha, beta=beta, coeff=coeff, &
- & x=x)
+ x=x)
END PROCEDURE JacobiInvTransform2
!----------------------------------------------------------------------------
@@ -1270,10 +1374,10 @@
MODULE PROCEDURE JacobiDMatrix1
SELECT CASE (quadType)
-CASE (GaussLobatto)
+CASE (qp%GaussLobatto)
CALL JacobiDMatrixGL(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType,&
& D=ans)
-CASE (Gauss)
+CASE (qp%Gauss)
CALL JacobiDMatrixG(n=n, alpha=alpha, beta=beta, x=x, quadType=quadType, &
& D=ans)
END SELECT
diff --git a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90
index d08340e69..313f99916 100644
--- a/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/LagrangePolynomialUtility@Methods.F90
@@ -17,89 +17,95 @@
SUBMODULE(LagrangePolynomialUtility) Methods
USE GlobalData, ONLY: stdout, stderr, Point, Line, Triangle, Quadrangle, &
- Tetrahedron, Hexahedron, Prism, Pyramid
+ Tetrahedron, Hexahedron, Prism, Pyramid, Monomial
USE ErrorHandling, ONLY: Errormsg
-USE ReferenceElement_Method, ONLY: ElementTopology
+USE ReferenceElement_Method, ONLY: ElementTopology, XiDimension
-USE ReferenceLine_Method, ONLY: RefCoord_Line
-USE ReferenceTriangle_Method, ONLY: RefCoord_Triangle
-USE ReferenceQuadrangle_Method, ONLY: RefCoord_Quadrangle
-USE ReferenceTetrahedron_Method, ONLY: RefCoord_Tetrahedron
-USE ReferenceHexahedron_Method, ONLY: RefCoord_Hexahedron
-USE ReferencePrism_Method, ONLY: RefCoord_Prism
-USE ReferencePyramid_Method, ONLY: RefCoord_Pyramid
-
-USE LineInterpolationUtility, ONLY: RefElemDomain_Line, &
- LagrangeDOF_Line, &
+USE LineInterpolationUtility, ONLY: LagrangeDOF_Line, &
LagrangeInDOF_Line, &
LagrangeDegree_Line, &
EquidistancePoint_Line, &
+ EquidistancePoint_Line_, &
InterpolationPoint_Line, &
+ InterpolationPoint_Line_, &
LagrangeCoeff_Line, &
- LagrangeEvalAll_Line, &
- LagrangeGradientEvalAll_Line
+ LagrangeCoeff_Line_, &
+ LagrangeEvalAll_Line_, &
+ LagrangeGradientEvalAll_Line_
-USE TriangleInterpolationUtility, ONLY: RefElemDomain_Triangle, &
- LagrangeDOF_Triangle, &
+USE TriangleInterpolationUtility, ONLY: LagrangeDOF_Triangle, &
LagrangeInDOF_Triangle, &
LagrangeDegree_Triangle, &
EquidistancePoint_Triangle, &
+ EquidistancePoint_Triangle_, &
InterpolationPoint_Triangle, &
+ InterpolationPoint_Triangle_, &
LagrangeCoeff_Triangle, &
- LagrangeEvalAll_Triangle, &
- LagrangeGradientEvalAll_Triangle
+ LagrangeCoeff_Triangle_, &
+ LagrangeEvalAll_Triangle_, &
+ LagrangeGradientEvalAll_Triangle_
-USE QuadrangleInterpolationUtility, ONLY: RefElemDomain_Quadrangle, &
- LagrangeDOF_Quadrangle, &
+USE QuadrangleInterpolationUtility, ONLY: LagrangeDOF_Quadrangle, &
LagrangeInDOF_Quadrangle, &
LagrangeDegree_Quadrangle, &
EquidistancePoint_Quadrangle, &
+ EquidistancePoint_Quadrangle_, &
InterpolationPoint_Quadrangle, &
+ InterpolationPoint_Quadrangle_, &
LagrangeCoeff_Quadrangle, &
- LagrangeEvalAll_Quadrangle, &
- LagrangeGradientEvalAll_Quadrangle
+ LagrangeCoeff_Quadrangle_, &
+ LagrangeEvalAll_Quadrangle_, &
+ LagrangeGradientEvalAll_Quadrangle_
-USE TetrahedronInterpolationUtility, ONLY: RefElemDomain_Tetrahedron, &
- LagrangeDOF_Tetrahedron, &
+USE TetrahedronInterpolationUtility, ONLY: LagrangeDOF_Tetrahedron, &
LagrangeInDOF_Tetrahedron, &
LagrangeDegree_Tetrahedron, &
EquidistancePoint_Tetrahedron, &
+ EquidistancePoint_Tetrahedron_, &
InterpolationPoint_Tetrahedron, &
+ InterpolationPoint_Tetrahedron_, &
LagrangeCoeff_Tetrahedron, &
- LagrangeEvalAll_Tetrahedron, &
- LagrangeGradientEvalAll_Tetrahedron
+ LagrangeCoeff_Tetrahedron_, &
+ LagrangeEvalAll_Tetrahedron_, &
+ LagrangeGradientEvalAll_Tetrahedron_
-USE HexahedronInterpolationUtility, ONLY: RefElemDomain_Hexahedron, &
- LagrangeDOF_Hexahedron, &
+USE HexahedronInterpolationUtility, ONLY: LagrangeDOF_Hexahedron, &
LagrangeInDOF_Hexahedron, &
LagrangeDegree_Hexahedron, &
EquidistancePoint_Hexahedron, &
+ EquidistancePoint_Hexahedron_, &
InterpolationPoint_Hexahedron, &
+ InterpolationPoint_Hexahedron_, &
LagrangeCoeff_Hexahedron, &
- LagrangeEvalAll_Hexahedron, &
- LagrangeGradientEvalAll_Hexahedron
+ LagrangeCoeff_Hexahedron_, &
+ LagrangeEvalAll_Hexahedron_, &
+ LagrangeGradientEvalAll_Hexahedron_
-USE PrismInterpolationUtility, ONLY: RefElemDomain_Prism, &
- LagrangeDOF_Prism, &
+USE PrismInterpolationUtility, ONLY: LagrangeDOF_Prism, &
LagrangeInDOF_Prism, &
LagrangeDegree_Prism, &
EquidistancePoint_Prism, &
+ EquidistancePoint_Prism_, &
InterpolationPoint_Prism, &
+ InterpolationPoint_Prism_, &
LagrangeCoeff_Prism, &
- LagrangeEvalAll_Prism, &
- LagrangeGradientEvalAll_Prism
+ LagrangeCoeff_Prism_, &
+ LagrangeEvalAll_Prism_, &
+ LagrangeGradientEvalAll_Prism_
-USE PyramidInterpolationUtility, ONLY: RefElemDomain_Pyramid, &
- LagrangeDOF_Pyramid, &
+USE PyramidInterpolationUtility, ONLY: LagrangeDOF_Pyramid, &
LagrangeInDOF_Pyramid, &
LagrangeDegree_Pyramid, &
EquidistancePoint_Pyramid, &
+ EquidistancePoint_Pyramid_, &
InterpolationPoint_Pyramid, &
+ InterpolationPoint_Pyramid_, &
LagrangeCoeff_Pyramid, &
- LagrangeEvalAll_Pyramid, &
- LagrangeGradientEvalAll_Pyramid
+ LagrangeCoeff_Pyramid_, &
+ LagrangeEvalAll_Pyramid_, &
+ LagrangeGradientEvalAll_Pyramid_
USE ReallocateUtility, ONLY: Reallocate
@@ -109,85 +115,41 @@
CONTAINS
!----------------------------------------------------------------------------
-! RefElemDomain
+! LagrangeDOF
!----------------------------------------------------------------------------
-MODULE PROCEDURE RefElemDomain
+MODULE PROCEDURE LagrangeDOF1
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
-SELECT CASE (topo)
-CASE (Point)
- ans = ""
-
-CASE (Line)
- ans = RefElemDomain_Line(baseContinuity, baseInterpol)
-
-CASE (Triangle)
- ans = RefElemDomain_Triangle(baseContinuity, baseInterpol)
-
-CASE (Quadrangle)
- ans = RefElemDomain_Quadrangle(baseContinuity, baseInterpol)
-
-CASE (Tetrahedron)
- ans = RefElemDomain_Tetrahedron(baseContinuity, baseInterpol)
-
-CASE (Hexahedron)
- ans = RefElemDomain_Hexahedron(baseContinuity, baseInterpol)
-
-CASE (Prism)
- ans = RefElemDomain_Prism(baseContinuity, baseInterpol)
-
-CASE (Pyramid)
- ans = RefElemDomain_Pyramid(baseContinuity, baseInterpol)
-END SELECT
-
-END PROCEDURE RefElemDomain
-
-!----------------------------------------------------------------------------
-! RefCoord
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE RefCoord
-INTEGER(I4B) :: topo
-
-topo = ElementTopology(elemType)
+ans = 0
SELECT CASE (topo)
-
CASE (Point)
- CALL Reallocate(ans, 3_I4B, 1_I4B)
-
+ ans = 1
CASE (Line)
- ans = RefCoord_Line(refElem)
-
+ ans = LagrangeDOF_Line(order=order)
CASE (Triangle)
- ans = RefCoord_Triangle(refElem)
-
+ ans = LagrangeDOF_Triangle(order=order)
CASE (Quadrangle)
- ans = RefCoord_Quadrangle(refElem)
-
+ ans = LagrangeDOF_Quadrangle(order=order)
CASE (Tetrahedron)
- ans = RefCoord_Tetrahedron(refElem)
-
+ ans = LagrangeDOF_Tetrahedron(order=order)
CASE (Hexahedron)
- ans = RefCoord_Hexahedron(refElem)
-
+ ans = LagrangeDOF_Hexahedron(order=order)
CASE (Prism)
- ans = RefCoord_Prism(refElem)
-
+ ans = LagrangeDOF_Prism(order=order)
CASE (Pyramid)
- ans = RefCoord_Pyramid(refElem)
-
+ ans = LagrangeDOF_Pyramid(order=order)
END SELECT
-END PROCEDURE RefCoord
+END PROCEDURE LagrangeDOF1
!----------------------------------------------------------------------------
-! LagrangeDOF
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeDOF
+MODULE PROCEDURE LagrangeDOF2
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -196,21 +158,21 @@
CASE (Point)
ans = 1
CASE (Line)
- ans = LagrangeDOF_Line(order=order)
+ ans = LagrangeDOF_Line(order=p)
CASE (Triangle)
- ans = LagrangeDOF_Triangle(order=order)
+ ans = LagrangeDOF_Triangle(order=p)
CASE (Quadrangle)
- ans = LagrangeDOF_Quadrangle(order=order)
+ ans = LagrangeDOF_Quadrangle(p=p, q=q)
CASE (Tetrahedron)
- ans = LagrangeDOF_Tetrahedron(order=order)
+ ans = LagrangeDOF_Tetrahedron(order=p)
CASE (Hexahedron)
- ans = LagrangeDOF_Hexahedron(order=order)
+ ans = LagrangeDOF_Hexahedron(p=p, q=q, r=r)
CASE (Prism)
- ans = LagrangeDOF_Prism(order=order)
+ ans = LagrangeDOF_Prism(order=p)
CASE (Pyramid)
- ans = LagrangeDOF_Pyramid(order=order)
+ ans = LagrangeDOF_Pyramid(order=p)
END SELECT
-END PROCEDURE LagrangeDOF
+END PROCEDURE LagrangeDOF2
!----------------------------------------------------------------------------
! LagrangeInDOF
@@ -326,55 +288,121 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = XiDimension(elemType)
+END IF
+
+ncol = LagrangeDOF(order=order, elemType=elemType)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL EquidistancePoint_(order=order, elemType=elemType, ans=ans, nrow=nrow, &
+ ncol=ncol, xij=xij)
+
+END PROCEDURE EquidistancePoint
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = XiDimension(topo)
+END IF
+
+ncol = LagrangeDOF(order=order, elemType=elemType)
+
SELECT CASE (topo)
CASE (Point)
+
IF (PRESENT(xij)) THEN
- ans = xij
+ ncol = 1
+ ans(1:nrow, 1) = xij(1:nrow, 1)
ELSE
- ALLOCATE (ans(0, 0))
+ nrow = 0
+ ncol = 0
+ ! ALLOCATE (ans(0, 0))
END IF
CASE (Line)
- ans = EquidistancePoint_Line(order=order, xij=xij)
+ ! ans(1:nrow, 1:ncol) = EquidistancePoint_Line(order=order, xij=xij)
+ CALL EquidistancePoint_Line_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
CASE (Triangle)
- ans = EquidistancePoint_Triangle(order=order, xij=xij)
+ ! ans(1:nrow, 1:ncol) = EquidistancePoint_Triangle(order=order, xij=xij)
+ CALL EquidistancePoint_Triangle_(order=order, xij=xij, nrow=nrow, &
+ ncol=ncol, ans=ans)
CASE (Quadrangle)
- ans = EquidistancePoint_Quadrangle(order=order, xij=xij)
+ ! ans(1:nrow, 1:ncol) = EquidistancePoint_Quadrangle(order=order, xij=xij)
+ CALL EquidistancePoint_Quadrangle_(order=order, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Tetrahedron)
- ans = EquidistancePoint_Tetrahedron(order=order, xij=xij)
+ ! ans(1:nrow, 1:ncol) = EquidistancePoint_Tetrahedron(order=order, xij=xij)
+ CALL EquidistancePoint_Tetrahedron_(order=order, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Hexahedron)
- ans = EquidistancePoint_Hexahedron(order=order, xij=xij)
+ CALL EquidistancePoint_Hexahedron_(order=order, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Prism)
- ans = EquidistancePoint_Prism(order=order, xij=xij)
+ CALL EquidistancePoint_Prism_(order=order, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Pyramid)
- ans = EquidistancePoint_Pyramid(order=order, xij=xij)
+ CALL EquidistancePoint_Pyramid_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="EquidistancePoint()", &
- & file=__FILE__)
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ routine="EquidistancePoint()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+ RETURN
END SELECT
-END PROCEDURE EquidistancePoint
+
+END PROCEDURE EquidistancePoint_
!----------------------------------------------------------------------------
! InterpolationPoint
!----------------------------------------------------------------------------
MODULE PROCEDURE InterpolationPoint
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(Xij, 1)
+ELSE
+ nrow = XiDimension(elemType)
+END IF
+
+ncol = LagrangeDOF(order=order, elemType=elemType)
+ALLOCATE (ans(nrow, ncol))
+
+CALL InterpolationPoint_(order=order, elemType=elemType, ipType=ipType, &
+ xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+END PROCEDURE InterpolationPoint
+
+!----------------------------------------------------------------------------
+! InterpolationPoint
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -382,85 +410,66 @@
SELECT CASE (topo)
CASE (Point)
+
IF (PRESENT(xij)) THEN
- ans = xij
- ELSE
- ALLOCATE (ans(0, 0))
+ nrow = SIZE(xij, 1)
+ ncol = SIZE(xij, 2)
+ ans(1:nrow, 1:ncol) = xij(1:nrow, 1:ncol)
+ RETURN
END IF
+ nrow = 0
+ ncol = 0
+
CASE (Line)
- ans = InterpolationPoint_Line(&
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Line_(order=order, ipType=ipType, ans=ans, &
+ nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, beta=beta, &
+ lambda=lambda)
CASE (Triangle)
- ans = InterpolationPoint_Triangle( &
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Triangle_(order=order, ipType=ipType, ans=ans, &
+ nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, beta=beta, &
+ lambda=lambda)
CASE (Quadrangle)
- ans = InterpolationPoint_Quadrangle( &
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Quadrangle_(order=order, ipType=ipType, ans=ans, &
+ nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, &
+ beta=beta, lambda=lambda)
CASE (Tetrahedron)
- ans = InterpolationPoint_Tetrahedron( &
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Tetrahedron_(order=order, ipType=ipType, ans=ans, &
+ nrow=nrow, ncol=ncol, xij=xij, layout=layout, alpha=alpha, &
+ beta=beta, lambda=lambda)
CASE (Hexahedron)
- ans = InterpolationPoint_Hexahedron( &
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Hexahedron_(order=order, ipType=ipType, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, layout=layout, &
+ alpha=alpha, beta=beta, lambda=lambda)
CASE (Prism)
- ans = InterpolationPoint_Prism( &
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Prism_(order=order, ipType=ipType, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, layout=layout, &
+ alpha=alpha, beta=beta, lambda=lambda)
CASE (Pyramid)
- ans = InterpolationPoint_Pyramid( &
- & order=order, &
- & ipType=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha=alpha, beta=beta, lambda=lambda)
+ CALL InterpolationPoint_Pyramid_(order=order, ipType=ipType, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, layout=layout, alpha=alpha, beta=beta, &
+ lambda=lambda)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="InterpolationPoint()", &
- & file=__FILE__)
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ unitno=stdout, line=__LINE__, routine="InterpolationPoint()", &
+ file=__FILE__)
RETURN
END SELECT
-END PROCEDURE InterpolationPoint
+END PROCEDURE InterpolationPoint_
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeCoeff1
+MODULE PROCEDURE LagrangeCoeff1_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -468,43 +477,49 @@
SELECT CASE (topo)
CASE (Point)
+
CASE (Line)
- ans = LagrangeCoeff_Line(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE (Triangle)
- ans = LagrangeCoeff_Triangle(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Triangle_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE (Quadrangle)
- ans = LagrangeCoeff_Quadrangle(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE (Tetrahedron)
- ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE (Hexahedron)
- ans = LagrangeCoeff_Hexahedron(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE (Prism)
- ans = LagrangeCoeff_Prism(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Prism_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE (Pyramid)
- ans = LagrangeCoeff_Pyramid(order=order, xij=xij, i=i)
+ CALL LagrangeCoeff_Pyramid_(order=order, xij=xij, i=i, &
+ ans=ans, tsize=tsize)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="LagrangeCoeff1()", &
- & file=__FILE__)
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ routine="LagrangeCoeff1_()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+ RETURN
END SELECT
-END PROCEDURE LagrangeCoeff1
+END PROCEDURE LagrangeCoeff1_
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeCoeff2
+MODULE PROCEDURE LagrangeCoeff2_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -513,41 +528,45 @@
CASE (Point)
CASE (Line)
- ans = LagrangeCoeff_Line(order=order, xij=xij)
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Triangle)
- ans = LagrangeCoeff_Triangle(order=order, xij=xij)
+ CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=Monomial, &
+ refTriangle="UNIT", ans=ans, nrow=nrow, ncol=ncol)
CASE (Quadrangle)
- ans = LagrangeCoeff_Quadrangle(order=order, xij=xij)
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
CASE (Tetrahedron)
- ans = LagrangeCoeff_Tetrahedron(order=order, xij=xij)
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
CASE (Hexahedron)
- ans = LagrangeCoeff_Hexahedron(order=order, xij=xij)
+ CALL LagrangeCoeff_Hexahedron_(order=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
CASE (Prism)
- ans = LagrangeCoeff_Prism(order=order, xij=xij)
+ CALL LagrangeCoeff_Prism_(order=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
CASE (Pyramid)
- ans = LagrangeCoeff_Pyramid(order=order, xij=xij)
+ CALL LagrangeCoeff_Pyramid_(order=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="LagrangeCoeff2()", &
- & file=__FILE__)
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ unitno=stdout, line=__LINE__, routine="LagrangeCoeff2_()", &
+ file=__FILE__)
END SELECT
-END PROCEDURE LagrangeCoeff2
+END PROCEDURE LagrangeCoeff2_
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeCoeff3
+MODULE PROCEDURE LagrangeCoeff3_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -555,41 +574,47 @@
CASE (Point)
CASE (Line)
- ans = LagrangeCoeff_Line(order=order, i=i, v=v, isVandermonde=.TRUE.)
+ CALL LagrangeCoeff_Line_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE (Triangle)
- ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, isVandermonde=.TRUE.)
+ CALL LagrangeCoeff_Triangle_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE (Quadrangle)
- ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, isVandermonde=.TRUE.)
+ CALL LagrangeCoeff_Quadrangle_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE (Tetrahedron)
- ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, isVandermonde=.TRUE.)
+CALL LagrangeCoeff_Tetrahedron_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE (Hexahedron)
- ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, isVandermonde=.TRUE.)
+ CALL LagrangeCoeff_Hexahedron_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE (Prism)
- ans = LagrangeCoeff_Prism(order=order, i=i, v=v, isVandermonde=.TRUE.)
+ CALL LagrangeCoeff_Prism_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE (Pyramid)
- ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, isVandermonde=.TRUE.)
+ CALL LagrangeCoeff_Pyramid_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="LagrangeCoeff2()", &
- & file=__FILE__)
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ routine="LagrangeCoeff3_()", unitno=stdout, line=__LINE__, &
+ file=__FILE__)
+ RETURN
END SELECT
-END PROCEDURE LagrangeCoeff3
+
+END PROCEDURE LagrangeCoeff3_
!----------------------------------------------------------------------------
! LagrangeCoeff
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeCoeff4
+MODULE PROCEDURE LagrangeCoeff4_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -598,34 +623,83 @@
CASE (Point)
CASE (Line)
- ans = LagrangeCoeff_Line(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Line_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE (Triangle)
- ans = LagrangeCoeff_Triangle(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Triangle_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE (Quadrangle)
- ans = LagrangeCoeff_Quadrangle(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Quadrangle_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE (Tetrahedron)
- ans = LagrangeCoeff_Tetrahedron(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Tetrahedron_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE (Hexahedron)
- ans = LagrangeCoeff_Hexahedron(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Hexahedron_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE (Prism)
- ans = LagrangeCoeff_Prism(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Prism_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE (Pyramid)
- ans = LagrangeCoeff_Pyramid(order=order, i=i, v=v, ipiv=ipiv)
+ CALL LagrangeCoeff_Pyramid_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="LagrangeCoeff2()", &
- & file=__FILE__)
+ CALL Errormsg( &
+ msg="No CASE FOUND: elemType="//ToString(elemType), &
+ routine="LagrangeCoeff4_()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+ RETURN
END SELECT
+
+END PROCEDURE LagrangeCoeff4_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff1
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff1_(order=order, elemType=elemType, i=i, xij=xij, ans=ans, &
+ tsize=tsize)
+
+END PROCEDURE LagrangeCoeff1
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff2
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff2_(order=order, elemType=elemType, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+END PROCEDURE LagrangeCoeff2
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff3
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff3_(order=order, elemType=elemType, i=i, v=v, &
+ isVandermonde=isVandermonde, ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff3
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff4
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff4_(order=order, elemType=elemType, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff4
!----------------------------------------------------------------------------
@@ -633,6 +707,18 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll1
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll1_(order=order, elemType=elemType, x=x, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, domainName=domainName, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE LagrangeEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll1_
INTEGER(I4B) :: topo
topo = ElementTopology(elemType)
@@ -641,284 +727,226 @@
CASE (Point)
CASE (Line)
- ans = LagrangeEvalAll_Line( &
- & order=order, &
- & xij=xij, &
- & x=x, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! ans = LagrangeEvalAll_Line( &
+ CALL LagrangeEvalAll_Line_(order=order, xij=xij, x=x, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
CASE (Triangle)
- ans = LagrangeEvalAll_Triangle( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refTriangle=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! ans = LagrangeEvalAll_Triangle( &
+ CALL LagrangeEvalAll_Triangle_(order=order, x=x, xij=xij, &
+ refTriangle=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Quadrangle)
- ans = LagrangeEvalAll_Quadrangle( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! ans = LagrangeEvalAll_Quadrangle( &
+ CALL LagrangeEvalAll_Quadrangle_(order=order, x=x, xij=xij, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
CASE (Tetrahedron)
- ans = LagrangeEvalAll_Tetrahedron( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refTetrahedron=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! ans = LagrangeEvalAll_Tetrahedron( &
+ CALL LagrangeEvalAll_Tetrahedron_(order=order, x=x, xij=xij, &
+ refTetrahedron=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Hexahedron)
- ans = LagrangeEvalAll_Hexahedron( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+
+ ! ans = LagrangeEvalAll_Hexahedron( &
+ CALL LagrangeEvalAll_Hexahedron_(order=order, x=x, xij=xij, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
CASE (Prism)
- ans = LagrangeEvalAll_Prism( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refPrism=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! ans = LagrangeEvalAll_Prism( &
+ CALL LagrangeEvalAll_Prism_(order=order, x=x, xij=xij, &
+ refPrism=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE (Pyramid)
- ans = LagrangeEvalAll_Pyramid( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refPyramid=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! ans = LagrangeEvalAll_Pyramid( &
+ CALL LagrangeEvalAll_Pyramid_(order=order, x=x, xij=xij, &
+ refPyramid=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="LagrangeEvalAll2()", &
- & file=__FILE__)
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ routine="LagrangeEvalAll2()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+ RETURN
END SELECT
-END PROCEDURE LagrangeEvalAll1
+
+END PROCEDURE LagrangeEvalAll1_
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll1
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll1_(order=order, elemType=elemType, x=x, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, domainName=domainName, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+END PROCEDURE LagrangeGradientEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll1_
INTEGER(I4B) :: topo
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = SIZE(x, 1)
+
topo = ElementTopology(elemType)
SELECT CASE (topo)
CASE (Point)
CASE (Line)
+
+#ifdef DEBUG_VER
+
IF (SIZE(x, 1) .NE. 1 .OR. SIZE(xij, 1) .NE. 1) THEN
- CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 1", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 1", &
+ routine="LagrangeGradientEvalAll1", unitno=stderr, &
+ line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:1) = LagrangeGradientEvalAll_Line( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:1) = LagrangeGradientEvalAll_Line(order=order, &
+ CALL LagrangeGradientEvalAll_Line_(order=order, x=x, xij=xij, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
CASE (Triangle)
+#ifdef DEBUG_VER
+
IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN
- CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", &
+ routine="LagrangeGradientEvalAll1", &
+ unitno=stderr, line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:2) = LagrangeGradientEvalAll_Triangle( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refTriangle=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Triangle(order=order, &
+ CALL LagrangeGradientEvalAll_Triangle_(order=order, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3, x=x, xij=xij, refTriangle=domainName, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
CASE (Quadrangle)
+#ifdef DEBUG_VER
IF (SIZE(x, 1) .NE. 2 .OR. SIZE(xij, 1) .NE. 2) THEN
CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 2", &
+ routine="LagrangeGradientEvalAll1", &
+ unitno=stderr, line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:2) = LagrangeGradientEvalAll_Quadrangle( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:2) = LagrangeGradientEvalAll_Quadrangle( &
+ CALL LagrangeGradientEvalAll_Quadrangle_(order=order, x=x, xij=xij, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
CASE (Tetrahedron)
+#ifdef DEBUG_VER
+
IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN
- CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
+ routine="LagrangeGradientEvalAll1", &
+ unitno=stderr, line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:3) = LagrangeGradientEvalAll_Tetrahedron( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refTetrahedron=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Tetrahedron( &
+ CALL LagrangeGradientEvalAll_Tetrahedron_(order=order, x=x, xij=xij, &
+ refTetrahedron=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
CASE (Hexahedron)
+#ifdef DEBUG_VER
+
IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN
- CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
+ routine="LagrangeGradientEvalAll1", &
+ unitno=stderr, line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:3) = LagrangeGradientEvalAll_Hexahedron( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Hexahedron( &
+ CALL LagrangeGradientEvalAll_Hexahedron_(order=order, x=x, xij=xij, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
CASE (Prism)
+#ifdef DEBUG_VER
IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN
- CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
+ routine="LagrangeGradientEvalAll1", &
+ unitno=stderr, line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:3) = LagrangeGradientEvalAll_Prism( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refPrism=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Prism(order=order, &
+ CALL LagrangeGradientEvalAll_Prism_(order=order, x=x, xij=xij, &
+ refPrism=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
CASE (Pyramid)
+#ifdef DEBUG_VER
+
IF (SIZE(x, 1) .NE. 3 .OR. SIZE(xij, 1) .NE. 3) THEN
- CALL Errormsg( &
- & msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
- & unitno=stderr, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1", &
- & file=__FILE__)
+ CALL Errormsg(msg="SIZE(x, 1) or SIZE(xij, 1) .NE. 3", &
+ routine="LagrangeGradientEvalAll1", &
+ unitno=stderr, line=__LINE__, file=__FILE__)
RETURN
END IF
- ans(:, :, 1:3) = LagrangeGradientEvalAll_Pyramid( &
- & order=order, &
- & x=x, &
- & xij=xij, &
- & refPyramid=domainName, &
- & coeff=coeff, &
- & firstCall=firstCall, &
- & basisType=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+
+#endif
+
+ ! ans(1:dim1, 1:dim2, 1:3) = LagrangeGradientEvalAll_Pyramid(order=order, &
+ CALL LagrangeGradientEvalAll_Pyramid_(order=order, x=x, xij=xij, &
+ refPyramid=domainName, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
CASE DEFAULT
- CALL Errormsg(&
- & msg="No CASE FOUND: elemType="//ToString(elemType), &
- & unitno=stdout, &
- & line=__LINE__, &
- & routine="LagrangeGradientEvalAll1()", &
- & file=__FILE__)
+
+ CALL Errormsg(msg="No CASE FOUND: elemType="//ToString(elemType), &
+ routine="LagrangeGradientEvalAll1()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
RETURN
+
END SELECT
-END PROCEDURE LagrangeGradientEvalAll1
+END PROCEDURE LagrangeGradientEvalAll1_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90
index f91273474..2f3638d6b 100644
--- a/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/LegendrePolynomialUtility@Methods.F90
@@ -16,8 +16,27 @@
!
SUBMODULE(LegendrePolynomialUtility) Methods
-USE BaseMethod
+USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalDMatEvenOdd, &
+ UltrasphericalGradientCoeff
+
+USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix
+
+#ifdef USE_LAPACK95
+USE F95_Lapack, ONLY: STEV
+#endif
+
+USE JacobiPolynomialUtility, ONLY: JacobiZeros
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE MiscUtility, ONLY: Factorial
+
+USE BaseType, ONLY: qp => TypeQuadratureOpt
+
+USE GlobalData, ONLY: stderr
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -34,7 +53,7 @@
MODULE PROCEDURE LegendreBeta
REAL(DFP) :: avar
-!!
+
IF (n .EQ. 0_I4B) THEN
ans = 2.0_DFP
ELSE
@@ -51,18 +70,18 @@
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
!----------------------------------------------------------------------------
@@ -72,16 +91,16 @@
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;
+ A(ii - 1) = (2.0_DFP * j - 1.0_DFP) / j
+ C(ii - 1) = (j - 1.0_DFP) / j
END DO
-!!
+
END PROCEDURE GetLegendreRecurrenceCoeff2
!----------------------------------------------------------------------------
@@ -137,17 +156,17 @@
MODULE PROCEDURE LegendreJacobiMatrix
REAL(DFP), DIMENSION(0:n - 1) :: alphaCoeff0, betaCoeff0
-!!
+
IF (n .LT. 1) RETURN
-!!
+
CALL GetLegendreRecurrenceCoeff(n=n, alphaCoeff=alphaCoeff0, &
- & betaCoeff=betaCoeff0)
+ 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
!----------------------------------------------------------------------------
@@ -155,14 +174,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreGaussQuadrature
-REAL(DFP) :: pn(n), fixvar
+#ifdef USE_LAPACK95
+REAL(DFP) :: fixvar
+REAL(DFP) :: pn(n)
INTEGER(I4B) :: ii
-!!
-CALL LegendreJacobiMatrix(n=n, D=pt, E=pn)
-!!
+#endif
+
#ifdef USE_LAPACK95
+CALL LegendreJacobiMatrix(n=n, D=pt, E=pn)
CALL STEV(D=pt, E=pn)
-!!
+
IF (PRESENT(wt)) THEN
wt = pn
pn = LegendreEval(n=n - 1, x=pt)
@@ -171,16 +192,15 @@
wt(ii) = fixvar * (1.0_DFP - pt(ii)**2) / (pn(ii)**2)
END DO
END IF
- !!
+
#else
-CALL ErrorMsg( &
- & msg="The subroutine requires Lapack95 package", &
- & file=__FILE__, &
- & routine="LegendreGaussQuadrature", &
- & line=__LINE__, &
- & unitno=stdout)
+CALL ErrorMsg(msg="The subroutine requires Lapack95 package", &
+ file=__FILE__, &
+ routine="LegendreGaussQuadrature", &
+ line=__LINE__, &
+ unitno=stderr)
#endif
- !!
+
END PROCEDURE LegendreGaussQuadrature
!----------------------------------------------------------------------------
@@ -188,22 +208,22 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreJacobiRadauMatrix
-REAL(DFP) :: avar, r1, r2
-!!
+REAL(DFP) :: 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
!----------------------------------------------------------------------------
@@ -211,34 +231,32 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreGaussRadauQuadrature
+#ifdef USE_LAPACK95
REAL(DFP) :: pn(n + 1), fixvar
INTEGER(I4B) :: ii
- !!
+
CALL LegendreJacobiRadauMatrix(a=a, n=n, D=pt, E=pn)
-!!
-#ifdef USE_LAPACK95
-!!
CALL STEV(D=pt, E=pn)
-!!
+
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( &
- & msg="The subroutine requires Lapack95 package", &
- & file=__FILE__, &
- & routine="LegendreGaussRadauQuadrature", &
- & line=__LINE__, &
- & unitno=stdout)
+
+CALL ErrorMsg(msg="The subroutine requires Lapack95 package", &
+ file=__FILE__, &
+ routine="LegendreGaussRadauQuadrature", &
+ line=__LINE__, &
+ unitno=stderr)
#endif
- !!
+
END PROCEDURE LegendreGaussRadauQuadrature
!----------------------------------------------------------------------------
@@ -246,24 +264,24 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreJacobiLobattoMatrix
- !!
+
REAL(DFP) :: r1, r2
- !!
+
IF (n .LT. 0) 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
!----------------------------------------------------------------------------
@@ -271,34 +289,33 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreGaussLobattoQuadrature
+#ifdef USE_LAPACK95
REAL(DFP) :: pn(n + 2), fixvar
INTEGER(I4B) :: ii
-!!
+
CALL LegendreJacobiLobattoMatrix(n=n, D=pt, E=pn)
-!!
-#ifdef USE_LAPACK95
-!!
+
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 + 1) * (n + 2), KIND=DFP)
- !!
+
DO ii = 1, n + 2
wt(ii) = fixvar / (pn(ii)**2)
END DO
END IF
- !!
+
#else
CALL ErrorMsg( &
& msg="The subroutine requires Lapack95 package", &
& file=__FILE__, &
& routine="LegendreGaussLobattoQuadrature", &
& line=__LINE__, &
- & unitno=stdout)
+ & unitno=stderr)
#endif
- !!
+
END PROCEDURE LegendreGaussLobattoQuadrature
!----------------------------------------------------------------------------
@@ -318,21 +335,21 @@
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)
- !!
+CASE (qp%Gauss)
+
order = n
CALL LegendreGaussQuadrature(n=order, pt=pt, wt=wt)
- !!
-CASE (GaussRadau, GaussRadauLeft)
- !!
+
+CASE (qp%GaussRadau, qp%GaussRadauLeft)
+
IF (inside) THEN
order = n
ALLOCATE (p(n + 1), w(n + 1))
@@ -343,9 +360,9 @@
order = n - 1
CALL LegendreGaussRadauQuadrature(a=left, n=order, pt=pt, wt=wt)
END IF
- !!
-CASE (GaussRadauRight)
- !!
+
+CASE (qp%GaussRadauRight)
+
IF (inside) THEN
order = n
ALLOCATE (p(n + 1), w(n + 1))
@@ -355,9 +372,9 @@
order = n - 1
CALL LegendreGaussRadauQuadrature(a=right, n=order, pt=pt, wt=wt)
END IF
- !!
-CASE (GaussLobatto)
- !!
+
+CASE (qp%GaussLobatto)
+
IF (inside) THEN
order = n
ALLOCATE (p(n + 2), w(n + 2))
@@ -377,33 +394,33 @@
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
@@ -415,33 +432,33 @@
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
@@ -450,70 +467,87 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreEvalAll1
+INTEGER(I4B) :: tsize
+CALL LegendreEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE LegendreEvalAll1
+
+!----------------------------------------------------------------------------
+! LegendreEvalAll_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LegendreEvalAll1_
INTEGER(I4B) :: i
REAL(DFP) :: c1, c2, c3, r_i
-!!
-ans = 0.0_DFP
-!!
-IF (n < 0) THEN
- RETURN
-END IF
-!!
+
+tsize = 0
+IF (n < 0) RETURN
+
+tsize = n + 1
ans(1) = 1.0_DFP
-!!
-IF (n .EQ. 0) THEN
- RETURN
-END IF
-!!
+
+IF (n .EQ. 0) RETURN
+
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
+ c2 = c2 / c1
+
c3 = -r_i + 1.0_DFP
- !!
- ans(i + 1) = ((c2 * x) * ans(i) + c3 * ans(i - 1)) / c1
- !!
+ c3 = c3 / c1
+
+ ans(i + 1) = (c2 * x) * ans(i) + c3 * ans(i - 1)
END DO
-END PROCEDURE LegendreEvalAll1
+END PROCEDURE LegendreEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL LegendreEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LegendreEvalAll2
+
+!----------------------------------------------------------------------------
+! LegendreEvalAll_
+!----------------------------------------------------------------------------
+
+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
-!!
+
+nrow = 0; ncol = 0
+IF (n < 0) RETURN
+
+nrow = SIZE(x)
+ncol = n + 1
+
+ans(1:nrow, 1) = 1.0_DFP
+
+IF (n .EQ. 0) RETURN
+
+ans(1:nrow, 2) = x
+
DO i = 2, n
- !!
r_i = REAL(i, kind=DFP)
c1 = r_i
c2 = 2.0_DFP * r_i - 1.0_DFP
+ c2 = c2 / c1
+
c3 = -r_i + 1.0_DFP
- !!
- ans(:, i + 1) = ((c2 * x) * ans(:, i) + c3 * ans(:, i - 1)) / c1
- !!
+ c3 = c3 / c1
+
+ ans(1:nrow, i + 1) = (c2 * x) * ans(1:nrow, i) + c3 * ans(1:nrow, i - 1)
END DO
-END PROCEDURE LegendreEvalAll2
+END PROCEDURE LegendreEvalAll2_
!----------------------------------------------------------------------------
!
@@ -522,30 +556,30 @@
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
@@ -564,122 +598,138 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreGradientEvalAll1
- !!
+INTEGER(I4B) :: tsize
+CALL LegendreGradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE LegendreGradientEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LegendreGradientEvalAll1_
INTEGER(I4B) :: ii
REAL(DFP) :: r_ii
REAL(DFP) :: p(1:n + 1)
- !!
-IF (n < 0) THEN
- RETURN
-END IF
-!!
+
+tsize = 0
+
+IF (n < 0) RETURN
+
+tsize = n + 1
p(1) = 1.0_DFP
ans(1) = 0.0_DFP
- !!
-IF (n < 1) THEN
- RETURN
-END IF
-!!
+
+IF (n < 1) RETURN
+
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
+
+END PROCEDURE LegendreGradientEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreGradientEvalAll2
-!!
+INTEGER(I4B) :: nrow, ncol
+CALL LegendreGradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LegendreGradientEvalAll2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
-!!
+
+nrow = 0; ncol = 0
+
+IF (n < 0) RETURN
+
+nrow = SIZE(x)
+ncol = n + 1
+
+p(1:nrow, 1) = 1.0_DFP
+ans(1:nrow, 1) = 0.0_DFP
+
+IF (n < 1) RETURN
+
+p(1:nrow, 2) = x
+ans(1:nrow, 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)
- !!
+
+ p(1:nrow, ii + 1) = ((2.0_DFP * r_ii - 1) * x * p(1:nrow, ii) &
+ - (r_ii - 1.0_DFP) * p(1:nrow, ii - 1)) &
+ / r_ii
+
+ ans(1:nrow, ii + 1) = (2.0_DFP * r_ii - 1.0_DFP) * p(1:nrow, ii) &
+ + ans(1:nrow, ii - 1)
+
END DO
-!!
-END PROCEDURE LegendreGradientEvalAll2
+
+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
!----------------------------------------------------------------------------
@@ -687,46 +737,46 @@
!----------------------------------------------------------------------------
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
!----------------------------------------------------------------------------
@@ -737,21 +787,21 @@
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
!----------------------------------------------------------------------------
@@ -762,21 +812,21 @@
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
!----------------------------------------------------------------------------
@@ -787,12 +837,12 @@
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);
@@ -810,12 +860,12 @@
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);
@@ -834,17 +884,17 @@
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;
@@ -865,26 +915,26 @@
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;
+ 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
@@ -893,80 +943,93 @@
!----------------------------------------------------------------------------
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
-!!
+INTEGER(I4B) :: tsize
+CALL LegendreTransform1_(n=n, coeff=coeff, x=x, w=w, quadType=quadType, &
+ ans=ans, tsize=tsize)
END PROCEDURE LegendreTransform1
!----------------------------------------------------------------------------
-! LegendreTransform
+! 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)
+MODULE PROCEDURE LegendreTransform1_
+REAL(DFP), ALLOCATABLE :: PP(:, :)
+INTEGER(I4B) :: ii, jj, nips
+nips = SIZE(coeff)
+ALLOCATE (PP(nips, n + 1))
+
+CALL LegendreEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj)
+CALL LegendreTransform4_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, &
+ ans=ans, tsize=tsize)
+DEALLOCATE (PP)
+END PROCEDURE LegendreTransform1_
+
+!----------------------------------------------------------------------------
+! LegendreTransform4_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LegendreTransform4_
+INTEGER(I4B) :: ii, jj, nips
+REAL(DFP) :: nrmsqr, areal
+LOGICAL(LGT) :: abool
+
+tsize = n + 1
+nips = SIZE(coeff)
+
+DO jj = 0, n
+ areal = 0.0_DFP
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
END DO
+ nrmsqr = LegendreNormSQR(n=jj)
+ ans(jj) = areal / nrmsqr
END DO
-!!
-END PROCEDURE LegendreTransform2
+
+abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1)
+
+IF (abool) THEN
+ areal = 0.0_DFP
+ jj = n
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+
+ nrmsqr = 2.0_DFP / REAL(n, KIND=DFP)
+ ans(jj) = areal / nrmsqr
+END IF
+END PROCEDURE LegendreTransform4_
!----------------------------------------------------------------------------
! LegendreTransform
!----------------------------------------------------------------------------
MODULE PROCEDURE LegendreTransform3
-REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n)
+INTEGER(I4B) :: tsize
+CALL LegendreTransform3_(n=n, f=f, x1=x1, x2=x2, quadType=quadType, &
+ ans=ans, tsize=tsize)
+END PROCEDURE LegendreTransform3
+
+!----------------------------------------------------------------------------
+! LegendreTransform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LegendreTransform3_
+REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x
+REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP
INTEGER(I4B) :: ii
-!!
-CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt,&
- & quadType=quadType)
-!!
+
+CALL LegendreQuadrature(n=n + 1, pt=pt, wt=wt, quadType=quadType)
+
DO ii = 0, n
- coeff(ii) = f(pt(ii))
+ x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2
+ x = x * half
+ coeff(ii) = f(x)
END DO
-!!
-ans = LegendreTransform(n=n, coeff=coeff, x=pt, &
- & w=wt, quadType=quadType)
-!!
-END PROCEDURE LegendreTransform3
+
+CALL LegendreTransform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, &
+ ans=ans, tsize=tsize)
+
+END PROCEDURE LegendreTransform3_
!----------------------------------------------------------------------------
! LegendreInvTransform
@@ -998,9 +1061,9 @@
MODULE PROCEDURE LegendreDMatrix1
SELECT CASE (quadType)
-CASE (GaussLobatto)
+CASE (qp%GaussLobatto)
CALL LegendreDMatrixGL2(n=n, x=x, D=ans)
-CASE (Gauss)
+CASE (qp%Gauss)
CALL LegendreDMatrixG2(n=n, x=x, D=ans)
END SELECT
END PROCEDURE LegendreDMatrix1
@@ -1011,33 +1074,32 @@
PURE SUBROUTINE LegendreDMatrixGL(n, x, D)
INTEGER(I4B), INTENT(IN) :: n
- !! order of Jacobi polynomial
+ ! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: x(0:n)
- !! quadrature points
+ ! quadrature points
REAL(DFP), INTENT(OUT) :: D(0:n, 0:n)
- !! D matrix
- !!
- !! main
- !!
+ ! 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
!----------------------------------------------------------------------------
@@ -1046,45 +1108,45 @@ END SUBROUTINE LegendreDMatrixGL
PURE SUBROUTINE LegendreDMatrixGL2(n, x, D)
INTEGER(I4B), INTENT(IN) :: n
- !! order of Jacobi polynomial
+ ! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: x(0:n)
- !! quadrature points
+ ! quadrature points
REAL(DFP), INTENT(OUT) :: D(0:n, 0:n)
- !! D matrix
- !!
- !! main
- !!
+ ! 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
- !!
+
+ ! correct diagonal entries
+
DO ii = 0, nb2
D(ii, ii) = -SUM(D(ii, :))
END DO
- !!
- !! copy
- !!
+ !
+ ! copy
+
DO jj = 0, n
DO ii = 0, nb2
D(n - ii, n - jj) = -D(ii, jj)
END DO
END DO
- !!
+
END SUBROUTINE LegendreDMatrixGL2
!----------------------------------------------------------------------------
@@ -1093,21 +1155,21 @@ END SUBROUTINE LegendreDMatrixGL2
PURE SUBROUTINE LegendreDMatrixG(n, x, D)
INTEGER(I4B), INTENT(IN) :: n
- !! order of Jacobi polynomial
+ ! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: x(0:n)
- !! quadrature points
+ ! quadrature points
REAL(DFP), INTENT(OUT) :: D(0:n, 0:n)
- !! D matrix
- !!
- !! main
- !!
+ ! D matrix
+
+ ! main
+
REAL(DFP) :: J(0:n)
INTEGER(I4B) :: ii, jj
- !!
- !! Compute dJ_{N-1}(a+1,b+1)
- !!
+
+ ! 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
@@ -1117,7 +1179,7 @@ PURE SUBROUTINE LegendreDMatrixG(n, x, D)
END IF
END DO
END DO
-!!
+
END SUBROUTINE LegendreDMatrixG
!----------------------------------------------------------------------------
@@ -1126,45 +1188,40 @@ END SUBROUTINE LegendreDMatrixG
PURE SUBROUTINE LegendreDMatrixG2(n, x, D)
INTEGER(I4B), INTENT(IN) :: n
- !! order of Jacobi polynomial
+ ! order of Jacobi polynomial
REAL(DFP), INTENT(IN) :: x(0:n)
- !! quadrature points
+ ! quadrature points
REAL(DFP), INTENT(OUT) :: D(0:n, 0:n)
- !! D matrix
- !!
- !! internal variables
- !!
+ ! D matrix
+
+ ! internal variables
REAL(DFP) :: J(0:n)
INTEGER(I4B) :: ii, jj, nb2
- !!
- !! main
- !!
+
+ ! 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
- !!
+
+ ! correct diagonal entries
DO ii = 0, nb2
D(ii, ii) = -SUM(D(ii, :))
END DO
- !!
- !! copy
- !!
+
+ ! copy
DO jj = 0, n
DO ii = 0, nb2
D(n - ii, n - jj) = -D(ii, jj)
END DO
END DO
- !!
END SUBROUTINE LegendreDMatrixG2
!----------------------------------------------------------------------------
diff --git a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90
index ba2d7102b..32f34c324 100644
--- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90
@@ -16,7 +16,57 @@
!
SUBMODULE(LineInterpolationUtility) Methods
-USE BaseMethod
+USE BaseType, ONLY: ipopt => TypeInterpolationOpt, &
+ qpopt => TypeQuadratureOpt, &
+ polyopt => TypePolynomialOpt, &
+ elmopt => TypeElemNameOpt
+
+USE GlobalData, ONLY: stderr
+
+USE StringUtility, ONLY: UpperCase
+
+USE MappingUtility, ONLY: FromBiunitLine2Segment_, &
+ FromBiunitLine2Segment, &
+ FromUnitLine2BiUnitLine, &
+ FromUnitLine2BiUnitLine_
+
+USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol, &
+ GradientEvalAllOrthopol_, &
+ EvalAllOrthopol, &
+ EvalAllOrthopol_
+
+USE InputUtility, ONLY: Input
+
+USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde, &
+ LagrangeCoeff, &
+ LagrangeVandermonde_
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE LegendrePolynomialUtility, ONLY: LegendreQuadrature
+
+USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature
+
+USE JacobiPolynomialUtility, ONLY: JacobiQuadrature
+
+USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature
+
+USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat
+
+USE SortUtility, ONLY: HeapSort
+
+USE F95_BLAS, ONLY: GEMM
+
+#ifndef USE_BLAS95
+
+USE SwapUtility, ONLY: Swap
+
+#else
+
+USE F95_BLAS, ONLY: Swap
+
+#endif
+
IMPLICIT NONE
CONTAINS
@@ -34,7 +84,8 @@
MODULE PROCEDURE QuadratureNumber_Line
SELECT CASE (quadType)
-CASE (GaussLegendre, GaussChebyshev, GaussJacobi, GaussUltraspherical)
+CASE (qpopt%GaussLegendre, qpopt%GaussChebyshev, &
+ qpopt%GaussJacobi, qpopt%GaussUltraspherical)
ans = 1_I4B + INT(order / 2, kind=I4B)
CASE DEFAULT
ans = 2_I4B + INT(order / 2, kind=I4B)
@@ -114,382 +165,458 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistanceInPoint_Line1
-INTEGER(I4B) :: n, ii
-REAL(DFP) :: avar
+INTEGER(I4B) :: tsize
+
IF (order .LE. 1_I4B) THEN
ALLOCATE (ans(0))
RETURN
END IF
-n = LagrangeInDOF_Line(order=order)
-ALLOCATE (ans(n))
+
+tsize = LagrangeInDOF_Line(order=order)
+ALLOCATE (ans(tsize))
+CALL EquidistanceInPoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize)
+
+END PROCEDURE EquidistanceInPoint_Line1
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Line1_
+INTEGER(I4B) :: ii
+REAL(DFP) :: avar
+
+tsize = 0
+IF (order .LE. 1_I4B) RETURN
+
+tsize = LagrangeInDOF_Line(order=order)
+
avar = (xij(2) - xij(1)) / order
-DO ii = 1, n
- ans(ii) = xij(1) + ii * avar
+
+DO ii = 1, tsize
+ ans(ii) = xij(1) + REAL(ii, kind=dfp) * avar
END DO
-END PROCEDURE EquidistanceInPoint_Line1
+
+END PROCEDURE EquidistanceInPoint_Line1_
!----------------------------------------------------------------------------
! EquidistanceInPoint_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistanceInPoint_Line2
-INTEGER(I4B) :: n, ii, nsd
-REAL(DFP) :: x0(3, 2)
-REAL(DFP) :: avar(3)
+INTEGER(I4B) :: nrow, ncol
+
IF (order .LE. 1_I4B) THEN
ALLOCATE (ans(0, 0))
RETURN
END IF
+
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- x0(1:nsd, 1) = xij(1:nsd, 1)
- x0(1:nsd, 2) = xij(1:nsd, 2)
+ nrow = SIZE(xij, 1)
ELSE
- nsd = 1_I4B
- x0(1:nsd, 1) = [-1.0]
- x0(1:nsd, 2) = [1.0]
+ nrow = 1_I4B
END IF
-n = LagrangeInDOF_Line(order=order)
-ALLOCATE (ans(nsd, n))
-avar(1:nsd) = (x0(1:nsd, 2) - x0(1:nsd, 1)) / order
-DO ii = 1, n
- ans(1:nsd, ii) = x0(1:nsd, 1) + ii * avar(1:nsd)
-END DO
+
+ncol = LagrangeInDOF_Line(order=order)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
END PROCEDURE EquidistanceInPoint_Line2
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Line2_
+INTEGER(I4B) :: ii
+REAL(DFP) :: x0(3, 3)
+
+nrow = 0; ncol = 0
+IF (order .LE. 1_I4B) RETURN
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ x0(1:nrow, 1) = xij(1:nrow, 1)
+ x0(1:nrow, 2) = xij(1:nrow, 2)
+ELSE
+ nrow = 1_I4B
+ x0(1, 1) = -1.0
+ x0(1, 2) = 1.0
+END IF
+
+ncol = LagrangeInDOF_Line(order=order)
+
+x0(1:nrow, 3) = (x0(1:nrow, 2) - x0(1:nrow, 1)) / order
+
+DO ii = 1, ncol
+ ans(1:nrow, ii) = x0(1:nrow, 1) + ii * x0(1:nrow, 3)
+END DO
+END PROCEDURE EquidistanceInPoint_Line2_
+
!----------------------------------------------------------------------------
! EquidistancePoint_Line
!----------------------------------------------------------------------------
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
+INTEGER(I4B) :: tsize
+
+tsize = order + 1
+ALLOCATE (ans(tsize))
+CALL EquidistancePoint_Line1_(order=order, xij=xij, ans=ans, tsize=tsize)
END PROCEDURE EquidistancePoint_Line1
+!----------------------------------------------------------------------------
+! EquidistancePoint_Line_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Line1_
+INTEGER(I4B) :: tempint
+
+tsize = order + 1
+
+SELECT CASE (order)
+CASE (0)
+ ans(1) = 0.5_DFP * (xij(1) + xij(2))
+
+CASE (1)
+ ans(1) = xij(1)
+ ans(2) = xij(2)
+
+CASE DEFAULT
+ ans(1) = xij(1)
+ ans(2) = xij(2)
+ CALL EquidistanceInPoint_Line_(order=order, xij=xij, ans=ans(3:), &
+ tsize=tempint)
+END SELECT
+
+END PROCEDURE EquidistancePoint_Line1_
+
!----------------------------------------------------------------------------
! EquidistancePoint_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Line2
-INTEGER(I4B) :: nsd
+INTEGER(I4B) :: nrow, ncol
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))
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 1_I4B
+END IF
+
+ncol = order + 1
+ALLOCATE (ans(nrow, ncol))
+
+CALL EquidistancePoint_Line2_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE EquidistancePoint_Line2
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Line2_
+INTEGER(I4B) :: tempint
+
+ncol = order + 1
+
+SELECT CASE (order)
+
+CASE (0)
+
+ IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ ans(1:nrow, 1) = 0.5_DFP * (xij(1:nrow, 1) + xij(1:nrow, 2))
RETURN
END IF
- ans(1:nsd, 1) = xij(1:nsd, 1)
- ans(1:nsd, 2) = xij(1:nsd, 2)
-ELSE
- nsd = 1_I4B
- CALL Reallocate(ans, nsd, order + 1)
- IF (order .EQ. 0_I4B) THEN
- ans(1:nsd, 1) = 0.0_DFP
+
+ nrow = 1_I4B
+ ans(1, 1) = 0.0_DFP
+
+CASE (1)
+
+ IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ ans(1:nrow, 1:2) = xij(1:nrow, 1:2)
RETURN
END IF
- ans(1:nsd, 1) = [-1.0]
- ans(1:nsd, 2) = [1.0]
-END IF
-IF (order .GE. 2) THEN
- ans(1:nsd, 3:) = EquidistanceInPoint_Line(order=order, xij=xij)
-END IF
-END PROCEDURE EquidistancePoint_Line2
+
+ nrow = 1
+ ans(1, 1) = -1.0_DFP
+ ans(1, 2) = 1.0_DFP
+
+CASE DEFAULT
+
+ IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ ans(1:nrow, 1:2) = xij(1:nrow, 1:2)
+ ELSE
+ nrow = 1
+ ans(1, 1) = -1.0_DFP
+ ans(1, 2) = 1.0_DFP
+ END IF
+
+ CALL EquidistanceInPoint_Line2_(order=order, xij=xij, ans=ans(:, 3:), &
+ nrow=nrow, ncol=tempint)
+
+END SELECT
+
+END PROCEDURE EquidistancePoint_Line2_
!----------------------------------------------------------------------------
! InterpolationPoint_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE InterpolationPoint_Line1
-CHARACTER(20) :: astr
-INTEGER(I4B) :: nsd, ii
-REAL(DFP) :: temp(order + 1), t1
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 1
+END IF
+
+ncol = order + 1
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL InterpolationPoint_Line1_(order=order, ipType=ipType, ans=ans, &
+ nrow=nrow, ncol=ncol, layout=layout, xij=xij, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+END PROCEDURE InterpolationPoint_Line1
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Line2
+INTEGER(I4B) :: tsize
+tsize = order + 1
+ALLOCATE (ans(tsize))
+CALL InterpolationPoint_Line2_(order=order, ipType=ipType, &
+ xij=xij, layout=layout, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, tsize=tsize)
+END PROCEDURE InterpolationPoint_Line2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Line1_
+REAL(DFP) :: temp(64)
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 = 0.0_DFP
- END IF
+ CALL EquidistancePoint_Line_(xij=xij, order=order, ans=ans, nrow=nrow, &
+ ncol=ncol)
RETURN
END IF
-astr = TRIM(UpperCase(layout))
+CALL handle_error
+!! handle_error is defined in this routine, see below
+
+ncol = order + 1
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)
- 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 (ipopt%Equidistance)
+ CALL EquidistancePoint_Line_(xij=xij, order=order, nrow=nrow, ncol=ncol, &
+ ans=ans)
+ CALL handle_increasing
-CASE (GaussChebyshev)
- CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=Gauss)
+CASE (ipopt%GaussLegendre)
+ CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
-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 (ipopt%GaussChebyshev)
+ CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
-CASE (GaussJacobi)
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL ErrorMsg(&
- & msg="alpha and beta should be present for ipType=GaussJacobi", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE (ipopt%GaussLegendreLobatto)
+ CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=Gauss, &
- & alpha=alpha, &
- & beta=beta)
+CASE (ipopt%GaussChebyshevLobatto)
+ CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
-CASE (GaussJacobiLobatto)
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL ErrorMsg(&
- & msg="alpha and beta should be present for ipType=GaussJacobi", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE (ipopt%GaussJacobi)
+ CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss, &
+ alpha=alpha, beta=beta)
+ CALL handle_non_equidistance
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=GaussLobatto, &
- & alpha=alpha, &
- & beta=beta)
+CASE (ipopt%GaussJacobiLobatto)
+ CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto, &
+ alpha=alpha, beta=beta)
+ CALL handle_vefc
+ CALL handle_non_equidistance
- 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 (ipopt%GaussUltraspherical)
+CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss, &
+ lambda=lambda)
+ CALL handle_non_equidistance
-CASE (GaussUltraspherical)
- IF (.NOT. PRESENT(lambda)) THEN
- CALL ErrorMsg(&
- & msg="lambda should be present for ipType=GaussUltraspherical", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE (ipopt%GaussUltrasphericalLobatto)
+ CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%GaussLobatto, &
+ lambda=lambda)
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=Gauss, &
- & lambda=lambda)
+ CALL handle_vefc
+ CALL handle_non_equidistance
-CASE (GaussUltrasphericalLobatto)
- IF (.NOT. PRESENT(lambda)) THEN
- CALL ErrorMsg(&
- & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE DEFAULT
+ CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line1_()", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+END SELECT
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=GaussLobatto, &
- & lambda=lambda)
+CONTAINS
- IF (layout .EQ. "VEFC") THEN
+SUBROUTINE handle_vefc
+ REAL(DFP) :: t1
+
+ IF (layout(1:2) .EQ. "VE") THEN
t1 = temp(order + 1)
IF (order .GE. 2) THEN
- temp(3:) = temp(2:order)
+ temp(3:order + 1) = 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
+END SUBROUTINE handle_vefc
+
+SUBROUTINE handle_increasing
+ INTEGER(I4B) :: ii
+
+ IF (layout(1:2) .EQ. "IN") THEN
+ DO ii = 1, nrow
+ CALL HeapSort(ans(ii, :))
+ END DO
+ END IF
+END SUBROUTINE
-IF (ipType .NE. Equidistance) THEN
+SUBROUTINE handle_non_equidistance
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- CALL Reallocate(ans, nsd, order + 1)
- ans = FromBiunitLine2Segment(xin=temp, x1=xij(:, 1), &
- & x2=xij(:, 2))
+ CALL FromBiunitLine2Segment_(xin=temp(1:ncol), x1=xij(:, 1), x2=xij(:, 2), &
+ ans=ans, nrow=nrow, ncol=ncol)
ELSE
- CALL Reallocate(ans, 1, order + 1)
- ans(1, :) = temp
+ nrow = 1
+ ans(1, 1:ncol) = temp(1:ncol)
END IF
-END IF
-END PROCEDURE InterpolationPoint_Line1
+
+END SUBROUTINE handle_non_equidistance
+
+SUBROUTINE handle_error
+
+#ifdef DEBUG_VER
+ LOGICAL(LGT) :: isok
+ CHARACTER(:), ALLOCATABLE :: msg
+
+ SELECT CASE (ipType)
+ CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto)
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ IF (.NOT. isok) THEN
+ msg = "alpha and beta should be present for ipType=GaussJacobi"
+
+ CALL ErrorMsg(msg=msg, file=__FILE__, &
+ routine="InterpolationPoint_Line1_()", &
+ line=__LINE__, unitno=stderr)
+ END IF
+
+ CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto)
+ isok = PRESENT(lambda)
+ IF (.NOT. isok) THEN
+ msg = "lambda should be present for ipType=GaussUltraSpherical"
+ CALL ErrorMsg(msg=msg, file=__FILE__, &
+ routine="InterpolationPoint_Line1_()", &
+ line=__LINE__, unitno=stderr)
+ END IF
+ END SELECT
+
+#endif
+
+END SUBROUTINE handle_error
+
+END PROCEDURE InterpolationPoint_Line1_
!----------------------------------------------------------------------------
-! InterpolationPoint_Line
+! InterpolationPoint_Line2_
!----------------------------------------------------------------------------
-MODULE PROCEDURE InterpolationPoint_Line2
-CHARACTER(20) :: astr
-REAL(DFP) :: t1
-
+MODULE PROCEDURE InterpolationPoint_Line2_
+tsize = order + 1
IF (order .EQ. 0_I4B) THEN
- ans = [0.5_DFP * (xij(1) + xij(2))]
+ ans(1) = 0.5_DFP * (xij(1) + xij(2))
RETURN
END IF
-CALL Reallocate(ans, order + 1)
-astr = TRIM(UpperCase(layout))
+CALL handle_error
SELECT CASE (ipType)
-CASE (Equidistance)
- ans = EquidistancePoint_Line(xij=xij, order=order)
- IF (astr .EQ. "INCREASING") ans = SORT(ans)
- RETURN
-CASE (GaussLegendre)
- CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=Gauss)
+CASE (ipopt%Equidistance)
+ CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans)
-CASE (GaussLegendreLobatto)
- 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
+ IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans(1:tsize))
-CASE (GaussChebyshev)
- CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=Gauss)
+CASE (ipopt%GaussLegendre)
+ CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
-CASE (GaussChebyshevLobatto)
- 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 (ipopt%GaussChebyshev)
+ CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
-CASE (GaussJacobi)
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL ErrorMsg(&
- & msg="alpha and beta should be present for ipType=GaussJacobi", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE (ipopt%GaussJacobi)
+ CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, alpha=alpha, &
+ beta=beta)
+ CALL handle_non_equidistance
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=Gauss, &
- & alpha=alpha, &
- & beta=beta)
-
-CASE (GaussJacobiLobatto)
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL ErrorMsg(&
- & msg="alpha and beta should be present for ipType=GaussJacobiLobatto", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE (ipopt%GaussUltraspherical)
+ CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, &
+ lambda=lambda)
+ CALL handle_non_equidistance
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=GaussLobatto, &
- & alpha=alpha, &
- & beta=beta)
+CASE (ipopt%GaussLegendreLobatto)
+ CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
- 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 (ipopt%GaussChebyshevLobatto)
+ CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
-CASE (GaussUltraspherical)
- IF (.NOT. PRESENT(lambda)) THEN
- CALL ErrorMsg(&
- & msg="lambda should be present for ipType=GaussUltraspherical", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE (ipopt%GaussJacobiLobatto)
+ CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, alpha=alpha, &
+ beta=beta)
+ CALL handle_vefc
+ CALL handle_non_equidistance
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=Gauss, &
- & lambda=lambda)
+CASE (ipopt%GaussUltrasphericalLobatto)
+ CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, &
+ lambda=lambda)
+ CALL handle_vefc
+ CALL handle_non_equidistance
-CASE (GaussUltrasphericalLobatto)
- IF (.NOT. PRESENT(lambda)) THEN
- CALL ErrorMsg(&
- & msg="lambda should be present for ipType=GaussUltrasphericalLobatto", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
+CASE DEFAULT
+ CALL ErrorMsg(msg="Unknown iptype", routine="InterpolationPoint_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+END SELECT
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=GaussLobatto, &
- & lambda=lambda)
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
- IF (layout .EQ. "VEFC") THEN
+SUBROUTINE handle_vefc
+ REAL(DFP) :: t1
+
+ IF (layout(1:2) .EQ. "VE") THEN
t1 = ans(order + 1)
IF (order .GE. 2) THEN
ans(3:) = ans(2:order)
@@ -497,476 +624,718 @@
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
+END SUBROUTINE handle_vefc
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE handle_non_equidistance
+ CALL FromBiunitLine2Segment_(xin=ans, x1=xij(1), x2=xij(2), &
+ ans=ans, tsize=tsize)
+
+END SUBROUTINE handle_non_equidistance
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+SUBROUTINE handle_error
+
+#ifdef DEBUG_VER
+ LOGICAL(LGT) :: isok
+ CHARACTER(:), ALLOCATABLE :: msg
+
+ SELECT CASE (ipType)
+ CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto)
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ IF (.NOT. isok) THEN
+ msg = "alpha and beta should be present for ipType=GaussJacobi"
+
+ CALL ErrorMsg(msg=msg, file=__FILE__, &
+ routine="InterpolationPoint_Line1_()", &
+ line=__LINE__, unitno=stderr)
+ END IF
+
+ CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto)
+ isok = PRESENT(lambda)
+ IF (.NOT. isok) THEN
+ msg = "lambda should be present for ipType=GaussUltraSpherical"
+ CALL ErrorMsg(msg=msg, file=__FILE__, &
+ routine="InterpolationPoint_Line1_()", &
+ line=__LINE__, unitno=stderr)
+ END IF
+ END SELECT
+
+#endif
+
+END SUBROUTINE handle_error
+
+END PROCEDURE InterpolationPoint_Line2_
!----------------------------------------------------------------------------
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Line1
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Line1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff_Line1
+
+!----------------------------------------------------------------------------
+! 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)
-ans = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Line1
+INTEGER(I4B) :: info, nrow, ncol
+
+tsize = order + 1
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, &
+ ans=v, nrow=nrow, ncol=ncol)
+
+CALL GetLU(A=v, IPIV=ipiv, info=info)
+
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+
+END PROCEDURE LagrangeCoeff_Line1_
!----------------------------------------------------------------------------
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Line2
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Line2_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff_Line2
+
+!----------------------------------------------------------------------------
+! 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
+
+tsize = order + 1
+
+vtemp = v
+! ipiv = 0
+
+CALL GetLU(A=vtemp, IPIV=ipiv, info=info)
+
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+
+CALL LUSolve(A=vtemp, B=ans(1:tsize), 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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Line3_(order=order, i=i, v=v, ipiv=ipiv, ans=ans, &
+ tsize=tsize)
END PROCEDURE LagrangeCoeff_Line3
!----------------------------------------------------------------------------
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
+MODULE PROCEDURE LagrangeCoeff_Line3_
+INTEGER(I4B) :: info
+tsize = 1 + order
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), 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)
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff_Line4_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE LagrangeCoeff_Line4
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Line4_
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elmopt%Line, &
+ ans=ans, nrow=nrow, ncol=ncol)
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Line4_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Line5
-SELECT CASE (basisType)
-CASE (Monomial)
- ans = LagrangeCoeff_Line(order=order, xij=xij)
-CASE DEFAULT
- ans = EvalAllOrthopol(&
- & n=order, &
- & x=xij(1, :), &
- & orthopol=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
- CALL GetInvMat(ans)
-END SELECT
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff_Line5_(order=order, xij=xij, basisType=basisType, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE LagrangeCoeff_Line5
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Line5_
+IF (basisType .EQ. polyopt%Monomial) THEN
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+ RETURN
+END IF
+
+CALL EvalAllOrthopol_(n=order, x=xij(1, :), &
+ orthopol=basisType, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Line5_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Line1
+INTEGER(I4B) :: tsize
+CALL LagrangeEvalAll_Line1_(order=order, x=x, xij=xij, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=ans, tsize=tsize)
+END PROCEDURE LagrangeEvalAll_Line1
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Line1_
LOGICAL(LGT) :: firstCall0
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2))
-INTEGER(I4B) :: ii, orthopol0
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), x1(1)
+INTEGER(I4B) :: ii, orthopol0, nrow, ncol
-IF (SIZE(xij, 2) .NE. order + 1) THEN
- CALL Errormsg(&
- & msg="Size(xij, 1) .NE. order+1 ", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+tsize = SIZE(xij, 2)
+
+#ifdef DEBUG_VER
+
+IF (tsize .NE. order + 1) THEN
+ CALL Errormsg(msg="Size(xij, 1) .NE. order+1 ", &
+ routine="LagrangeEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
-orthopol0 = input(default=Monomial, option=basisType)
-firstCall0 = input(default=.TRUE., option=firstCall)
+#endif
+
+orthopol0 = Input(default=polyopt%Monomial, option=basisType)
+firstCall0 = Input(default=.TRUE., option=firstCall)
+
+! make coeff0
IF (PRESENT(coeff)) THEN
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, &
+ basisType=orthopol0, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff, nrow=nrow, ncol=ncol)
END IF
- coeff0 = TRANSPOSE(coeff)
+
+ ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff(1:nrow, 1:ncol))
+ coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize)
+
ELSE
- coeff0 = TRANSPOSE(LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & ))
+
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff0, nrow=nrow, ncol=ncol)
+
+ ! coeff0(1:nrow, 1:ncol) = TRANSPOSE(coeff0(1:nrow, 1:ncol))
END IF
-SELECT CASE (orthopol0)
-CASE (Monomial)
+IF (orthopol0 .EQ. polyopt%monomial) THEN
+
xx(1, 1) = 1.0_DFP
DO ii = 1, order
xx(1, ii + 1) = xx(1, ii) * x
END DO
-CASE DEFAULT
- xx = EvalAllOrthopol(&
- & n=order, &
- & x=[x], &
- & orthopol=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END SELECT
-ans = MATMUL(coeff0, xx(1, :))
+ELSE
+
+ x1(1) = x
+ CALL EvalAllOrthopol_(n=order, x=x1, orthopol=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ ans=xx, nrow=nrow, ncol=ncol)
-END PROCEDURE LagrangeEvalAll_Line1
+END IF
+
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :))
+END DO
+
+END PROCEDURE LagrangeEvalAll_Line1_
!----------------------------------------------------------------------------
! LagrangeEvalAll_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Line2
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll_Line2_(order=order, x=x, xij=xij, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeEvalAll_Line2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Line2_
LOGICAL(LGT) :: firstCall0
REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2))
-INTEGER(I4B) :: ii, orthopol0
+INTEGER(I4B) :: ii, orthopol0, aint, bint
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
-IF (SIZE(xij, 2) .NE. order + 1) THEN
- CALL Errormsg(&
- & msg="Size(xij, 1) .NE. order+1 ", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+
+IF (ncol .NE. order + 1) THEN
+ CALL Errormsg(msg="Size(xij, 1) .NE. order+1 ", &
+ routine="LagrangeEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
-orthopol0 = Input(default=Monomial, option=basisType)
+#endif
+
+orthopol0 = Input(default=polyopt%Monomial, option=basisType)
firstCall0 = Input(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+ ! coeff = LagrangeCoeff_Line(&
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=coeff, nrow=aint, ncol=bint)
END IF
- coeff0 = coeff
+
+ coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol)
+
ELSE
- coeff0 = LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
+
+ ! coeff0 = LagrangeCoeff_Line(&
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=aint, ncol=bint)
+
END IF
-SELECT CASE (orthopol0)
-CASE (Monomial)
+IF (orthopol0 .EQ. polyopt%monomial) THEN
+
xx(:, 1) = 1.0_DFP
DO ii = 1, order
xx(:, ii + 1) = xx(:, ii) * x(1, :)
END DO
-CASE DEFAULT
- xx = EvalAllOrthopol(&
- & n=order, &
- & x=x(1, :), &
- & orthopol=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END SELECT
-ans = MATMUL(xx, coeff0)
+ELSE
-END PROCEDURE LagrangeEvalAll_Line2
+ ! xx = EvalAllOrthopol(
+ CALL EvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=xx, nrow=aint, ncol=bint)
+
+END IF
+
+! ans = MATMUL(xx, coeff0)
+CALL GEMM(C=ans, alpha=1.0_DFP, A=xx, B=coeff0)
+
+END PROCEDURE LagrangeEvalAll_Line2_
!----------------------------------------------------------------------------
! EvalAll_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE BasisEvalAll_Line1
-INTEGER(I4B) :: ii, basisType0
-TYPE(String) :: astr
-astr = UpperCase(refLine)
+INTEGER(I4B) :: tsize
+CALL BasisEvalAll_Line1_(order=order, x=x, ans=ans, tsize=tsize, &
+ refline=refline, basistype=basistype, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE BasisEvalAll_Line1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisEvalAll_Line1_
+#ifdef DEBUG_VER
+CHARACTER(1) :: astr
+#endif
+
+INTEGER(I4B) :: ii, basisType0, nrow, ncol
+REAL(DFP) :: temp(1, 100), x1(1)
-IF (astr%chars() .EQ. "UNIT") THEN
- CALL Errormsg(&
- & msg="refLine should be BIUNIT", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+tsize = order + 1
+
+#ifdef DEBUG_VER
+
+astr = UpperCase(refLine(1:1))
+IF (astr .EQ. "U") THEN
+ CALL Errormsg(msg="refLine should be BIUNIT", &
+ routine="BasisEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
-basisType0 = input(default=Monomial, option=basisType)
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+
SELECT CASE (basisType0)
-CASE (Monomial)
+
+CASE (polyopt%Monomial)
ans(1) = 1.0_DFP
DO ii = 1, order
ans(ii + 1) = ans(ii) * x
END DO
+
CASE DEFAULT
- IF (basisType0 .EQ. Jacobi) THEN
+#ifdef DEBUG_VER
+
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL Errormsg(&
- & msg="alpha and beta should be present for basisType=Jacobi", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="alpha and beta should be present for basisType=Jacobi", &
+ routine="BasisEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
END IF
- IF (basisType0 .EQ. Ultraspherical) THEN
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
IF (.NOT. PRESENT(lambda)) THEN
- CALL Errormsg(&
- & msg="lambda should be present for basisType=Ultraspherical", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="lambda should be present for basisType=Ultraspherical", &
+ routine="BasisEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
END IF
- ans = RESHAPE(EvalAllOrthopol(&
- & n=order, &
- & x=[x], &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda), [order + 1])
+ IF (order + 1 .GT. SIZE(temp, 2)) THEN
+ CALL Errormsg( &
+ msg="order+1 is greater than number of col in temp", &
+ routine="BasisEvalAll_Line1_", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
+ END IF
+
+#endif
+
+ x1(1) = x
+ CALL EvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=temp, nrow=nrow, ncol=ncol)
+
+ ans(1:tsize) = temp(1, 1:tsize)
+
END SELECT
-END PROCEDURE BasisEvalAll_Line1
+END PROCEDURE BasisEvalAll_Line1_
!----------------------------------------------------------------------------
! BasisGradientEvalAll_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE BasisGradientEvalAll_Line1
+INTEGER(I4B) :: tsize
+CALL BasisGradientEvalAll_Line1_(order=order, x=x, refLine=refLine, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ tsize=tsize)
+END PROCEDURE BasisGradientEvalAll_Line1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisGradientEvalAll_Line1_
INTEGER(I4B) :: ii, basisType0
-TYPE(String) :: astr
-astr = UpperCase(refLine)
+CHARACTER(:), ALLOCATABLE :: astr
+REAL(DFP) :: areal, breal, x1(1), temp(1, order + 1)
-IF (astr%chars() .EQ. "UNIT") THEN
- CALL Errormsg(&
- & msg="refLine should be BIUNIT", &
- & file=__FILE__, &
- & routine="BasisGradientEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+astr = UpperCase(refline)
+
+tsize = order + 1
+
+#ifdef DEBUG_VER
+
+IF (astr .EQ. "UNIT") THEN
+ CALL Errormsg(msg="refLine should be BIUNIT", &
+ routine="BasisGradientEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
-basisType0 = input(default=Monomial, option=basisType)
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
SELECT CASE (basisType0)
-CASE (Monomial)
+
+CASE (polyopt%Monomial)
+
ans(1) = 0.0_DFP
DO ii = 1, order
- ans(ii + 1) = REAL(ii, dfp) * x**(ii - 1)
+ areal = REAL(ii, kind=DFP)
+ breal = x**(ii - 1)
+ ans(ii + 1) = areal * breal
END DO
+
CASE DEFAULT
- IF (basisType0 .EQ. Jacobi) THEN
+#ifdef DEBUG_VER
+
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
+
IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL Errormsg(&
- & msg="alpha and beta should be present for basisType=Jacobi", &
- & file=__FILE__, &
- & routine="BasisGradientEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="alpha and beta should be present for basisType=Jacobi", &
+ routine="BasisGradientEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
+
END IF
- IF (basisType0 .EQ. Ultraspherical) THEN
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
+
IF (.NOT. PRESENT(lambda)) THEN
- CALL Errormsg(&
- & msg="lambda should be present for basisType=Ultraspherical", &
- & file=__FILE__, &
- & routine="BasisGradientEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="lambda should be present for basisType=Ultraspherical", &
+ routine="BasisGradientEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
+
END IF
- ans = RESHAPE(GradientEvalAllOrthopol(&
- & n=order, &
- & x=[x], &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda), [order + 1])
+#endif
+
+ x1(1) = x
+ CALL GradientEvalAllOrthopol_(n=order, x=x1, orthopol=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=temp, nrow=ii, ncol=tsize)
+
+ ans(1:tsize) = temp(1, 1:tsize)
+
END SELECT
-END PROCEDURE BasisGradientEvalAll_Line1
+END PROCEDURE BasisGradientEvalAll_Line1_
!----------------------------------------------------------------------------
-! BasisEvalAll_Line
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE BasisEvalAll_Line2
-INTEGER(I4B) :: ii, basisType0
-TYPE(String) :: astr
+MODULE PROCEDURE BasisGradientEvalAll_Line2
+INTEGER(I4B) :: nrow, ncol
+CALL BasisGradientEvalAll_Line2_(order=order, x=x, ans=ans, nrow=nrow, &
+ ncol=ncol, refLine=refLine, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE BasisGradientEvalAll_Line2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisGradientEvalAll_Line2_
+INTEGER(I4B) :: ii, basisType0, jj
+REAL(DFP) :: areal, breal
+CHARACTER(:), ALLOCATABLE :: astr
+
+nrow = SIZE(x)
+ncol = 1 + order
+
astr = UpperCase(refLine)
-IF (astr%chars() .EQ. "UNIT") THEN
- CALL Errormsg(&
- & msg="refLine should be BIUNIT", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+
+IF (astr .EQ. "UNIT") THEN
+ CALL Errormsg(msg="refLine should be BIUNIT", &
+ routine="BasisGradientEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
-basisType0 = input(default=Monomial, option=basisType)
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
SELECT CASE (basisType0)
-CASE (Monomial)
- ans(:, 1) = 1.0_DFP
+
+CASE (polyopt%Monomial)
+
+ ans(1:nrow, 1) = 0.0_DFP
+
DO ii = 1, order
- ans(:, ii + 1) = ans(:, ii) * x
+ areal = REAL(ii, kind=dfp)
+
+ DO jj = 1, nrow
+
+ breal = x(jj)**(ii - 1)
+ ans(jj, ii + 1) = areal * breal
+
+ END DO
+
END DO
+
CASE DEFAULT
- IF (basisType0 .EQ. Jacobi) THEN
+#ifdef DEBUG_VER
+
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL Errormsg(&
- & msg="alpha and beta should be present for basisType=Jacobi", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="alpha and beta should be present for basisType=Jacobi", &
+ routine="BasisGradientEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
END IF
- IF (basisType0 .EQ. Ultraspherical) THEN
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
IF (.NOT. PRESENT(lambda)) THEN
- CALL Errormsg(&
- & msg="lambda should be present for basisType=Ultraspherical", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="lambda should be present for basisType=Ultraspherical", &
+ routine="BasisGradientEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
END IF
- ans = EvalAllOrthopol(&
- & n=order, &
- & x=x, &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+#endif
+
+ ! ans = GradientEvalAllOrthopol(&
+ CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
END SELECT
+END PROCEDURE BasisGradientEvalAll_Line2_
+
+!----------------------------------------------------------------------------
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisEvalAll_Line2
+INTEGER(I4B) :: nrow, ncol
+CALL BasisEvalAll_Line2_(order=order, x=x, ans=ans, nrow=nrow, ncol=ncol, &
+ refline=refline, basistype=basistype, &
+ alpha=alpha, beta=beta, lambda=lambda)
END PROCEDURE BasisEvalAll_Line2
!----------------------------------------------------------------------------
-! BasisGradientEvalAll_Line
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE BasisGradientEvalAll_Line2
+MODULE PROCEDURE BasisEvalAll_Line2_
+#ifdef DEBUG_VER
+CHARACTER(1) :: astr
+
+#endif
+
INTEGER(I4B) :: ii, basisType0
-TYPE(String) :: astr
-astr = UpperCase(refLine)
-IF (astr%chars() .EQ. "UNIT") THEN
- CALL Errormsg(&
- & msg="refLine should be BIUNIT", &
- & file=__FILE__, &
- & routine="BasisGradientEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+nrow = SIZE(x)
+ncol = order + 1
+
+#ifdef DEBUG_VER
+
+astr = UpperCase(refline(1:1))
+
+IF (astr .EQ. "U") THEN
+ CALL Errormsg(msg="refLine should be BIUNIT", &
+ routine="BasisEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
-basisType0 = input(default=Monomial, option=basisType)
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+
SELECT CASE (basisType0)
-CASE (Monomial)
- ans(:, 1) = 0.0_DFP
+
+CASE (polyopt%Monomial)
+ ans(1:nrow, 1) = 1.0_DFP
DO ii = 1, order
- ans(:, ii + 1) = REAL(ii, dfp) * x**(ii - 1)
+ ans(1:nrow, ii + 1) = ans(1:nrow, ii) * x
END DO
+
CASE DEFAULT
- IF (basisType0 .EQ. Jacobi) THEN
+#ifdef DEBUG_VER
+
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL Errormsg(&
- & msg="alpha and beta should be present for basisType=Jacobi", &
- & file=__FILE__, &
- & routine="BasisGradientEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="alpha and beta should be present for basisType=Jacobi", &
+ routine="BasisEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
END IF
- IF (basisType0 .EQ. Ultraspherical) THEN
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
IF (.NOT. PRESENT(lambda)) THEN
- CALL Errormsg(&
- & msg="lambda should be present for basisType=Ultraspherical", &
- & file=__FILE__, &
- & routine="BasisGradientEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL Errormsg( &
+ msg="lambda should be present for basisType=Ultraspherical", &
+ routine="BasisEvalAll_Line2", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
END IF
- ans = GradientEvalAllOrthopol(&
- & n=order, &
- & x=x, &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+#endif
+
+ CALL EvalAllOrthopol_(n=order, x=x, orthopol=basisType0, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
END SELECT
-END PROCEDURE BasisGradientEvalAll_Line2
+END PROCEDURE BasisEvalAll_Line2_
+
+!----------------------------------------------------------------------------
+! BasisGradientEvalAll_Line
+!----------------------------------------------------------------------------
!----------------------------------------------------------------------------
! QuadraturePoint_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Line1
-INTEGER(I4B) :: nips(1)
+INTEGER(I4B) :: nips(1), nrow, ncol
+
nips(1) = QuadratureNumber_Line(order=order, quadType=quadType)
-ans = QuadraturePoint_Line3(nips=nips, quadType=quadType, &
-& layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda)
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 1
+END IF
+
+nrow = nrow + 1
+ncol = nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, &
+ xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
END PROCEDURE QuadraturePoint_Line1
!----------------------------------------------------------------------------
@@ -974,63 +1343,113 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Line2
-ans = QuadraturePoint_Line1(&
- & order=order, &
- & quadType=quadType, &
- & layout=layout, &
- & xij=RESHAPE(xij, [1, 2]), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+INTEGER(I4B) :: nips(1), nrow, ncol
+REAL(DFP) :: x12(1, 2)
+
+nips(1) = QuadratureNumber_Line(order=order, quadType=quadType)
+nrow = 2
+ncol = nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+x12(1, 1:2) = xij(1:2)
+
+CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, &
+ xij=x12, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE QuadraturePoint_Line2
+!----------------------------------------------------------------------------
+! QuadraturePoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Line3
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 1
+END IF
+
+nrow = nrow + 1
+ncol = nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, &
+ xij=xij, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+END PROCEDURE QuadraturePoint_Line3
+
!----------------------------------------------------------------------------
! QuadraturePoint_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Line4
-ans = QuadraturePoint_Line3(&
- & nips=nips, &
- & quadType=quadType, &
- & layout=layout, &
- & xij=RESHAPE(xij, [1, 2]), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+REAL(DFP) :: x12(1, 2)
+INTEGER(I4B) :: nrow, ncol
+
+nrow = 2
+ncol = nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+x12(1, 1:2) = xij(1:2)
+
+CALL QuadraturePoint_Line1_(nips=nips, quadType=quadType, layout=layout, &
+ xij=x12, alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
END PROCEDURE QuadraturePoint_Line4
!----------------------------------------------------------------------------
-! QuadraturePoint_Line
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE QuadraturePoint_Line3
-CHARACTER(20) :: astr
-INTEGER(I4B) :: np, nsd, ii
-REAL(DFP) :: pt(nips(1)), wt(nips(1))
-REAL(DFP) :: t1
+MODULE PROCEDURE QuadraturePoint_Line1_
+#ifdef DEBUG_VER
+LOGICAL(LGT) :: isok
+#endif
+
+INTEGER(I4B) :: np, nsd, ii, jj
+REAL(DFP) :: areal
LOGICAL(LGT) :: changeLayout
-IF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL ErrorMsg(&
- & msg="alpha and beta should be present for quadType=GaussJacobi", &
- & file=__FILE__, &
- & routine="QuadraturePoint_Line3", &
- & line=__LINE__, &
- & unitno=stderr)
+nrow = 0
+ncol = 0
+
+#ifdef DEBUG_VER
+
+SELECT CASE (quadType)
+CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto, &
+ ipopt%GaussJacobiRadauLeft, ipopt%GaussJacobiRadauRight)
+
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+
+ IF (.NOT. isok) THEN
+ CALL ErrorMsg(routine="QuadraturePoint_Line3", &
+ msg="alpha and beta should be present for quadType=ipopt%GaussJacobi", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
END IF
- RETURN
-ELSEIF (ANY([GaussJacobi, GaussJacobiLobatto] .EQ. quadType)) THEN
- IF (.NOT. PRESENT(lambda)) THEN
- CALL ErrorMsg(&
- & msg="lambda should be present for quadType=GaussUltraspherical", &
- & file=__FILE__, &
- & routine="QuadraturePoint_Line3", &
- & line=__LINE__, &
- & unitno=stderr)
+
+CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto, &
+ ipopt%GaussUltraSphericalRadauLeft, ipopt%GaussUltraSphericalRadauRight)
+
+ isok = PRESENT(lambda)
+
+ IF (.NOT. isok) THEN
+ CALL ErrorMsg(routine="QuadraturePoint_Line3", &
+ msg="lambda should be present for quadType=ipopt%GaussUltraspherical", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
END IF
- RETURN
-END IF
+
+END SELECT
+
+#endif
IF (PRESENT(xij)) THEN
nsd = SIZE(xij, 1)
@@ -1038,135 +1457,104 @@
nsd = 1
END IF
-astr = TRIM(UpperCase(layout))
np = nips(1)
-CALL Reallocate(ans, nsd + 1_I4B, np)
+nrow = nsd + 1
+ncol = nips(1)
+
changeLayout = .FALSE.
+IF (layout(1:1) .EQ. "V") changeLayout = .TRUE.
SELECT CASE (quadType)
-CASE (GaussLegendre)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss)
+CASE (ipopt%GaussLegendre)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%Gauss)
-CASE (GaussLegendreRadauLeft)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft)
+CASE (ipopt%GaussLegendreRadauLeft)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft)
-CASE (GaussLegendreRadauRight)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight)
+CASE (ipopt%GaussLegendreRadauRight)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauRight)
-CASE (GaussLegendreLobatto)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
+CASE (ipopt%GaussLegendreLobatto)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussLobatto)
-CASE (GaussChebyshev)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=Gauss)
+CASE (ipopt%GaussChebyshev)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%Gauss)
-CASE (GaussChebyshevRadauLeft)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft)
+CASE (ipopt%GaussChebyshevRadauLeft)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft)
-CASE (GaussChebyshevRadauRight)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight)
+CASE (ipopt%GaussChebyshevRadauRight)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauRight)
-CASE (GaussChebyshevLobatto)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
+CASE (ipopt%GaussChebyshevLobatto)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussLobatto)
-CASE (GaussJacobi)
- CALL JacobiQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=Gauss, &
- & alpha=alpha, &
- & beta=beta)
-
-CASE (GaussJacobiRadauLeft)
- CALL JacobiQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussRadauLeft, &
- & alpha=alpha, &
- & beta=beta)
-
-CASE (GaussJacobiRadauRight)
- CALL JacobiQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussRadauRight, &
- & alpha=alpha, &
- & beta=beta)
-
-CASE (GaussJacobiLobatto)
- CALL JacobiQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussLobatto, &
- & alpha=alpha, &
- & beta=beta)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
-
-CASE (GaussUltraspherical)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=Gauss, &
- & lambda=lambda)
+CASE (ipopt%GaussJacobi)
+ CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%Gauss, alpha=alpha, beta=beta)
-CASE (GaussUltrasphericalRadauLeft)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussRadauLeft, &
- & lambda=lambda)
+CASE (ipopt%GaussJacobiRadauLeft)
+ CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft, alpha=alpha, beta=beta)
-CASE (GaussUltrasphericalRadauRight)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussRadauRight, &
- & lambda=lambda)
+CASE (ipopt%GaussJacobiRadauRight)
+ CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauRight, alpha=alpha, beta=beta)
-CASE (GaussUltrasphericalLobatto)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussLobatto, &
- & lambda=lambda)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
+CASE (ipopt%GaussJacobiLobatto)
+ CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussLobatto, alpha=alpha, beta=beta)
+
+CASE (ipopt%GaussUltraspherical)
+CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%Gauss, lambda=lambda)
+
+CASE (ipopt%GaussUltrasphericalRadauLeft)
+CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft, lambda=lambda)
+
+CASE (ipopt%GaussUltrasphericalRadauRight)
+CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauRight, lambda=lambda)
+
+CASE (ipopt%GaussUltrasphericalLobatto)
+CALL UltrasphericalQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussLobatto, lambda=lambda)
CASE DEFAULT
- CALL ErrorMsg(&
- & msg="Unknown iptype", &
- & file=__FILE__, &
- & routine="QuadraturePoint_Line3", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL ErrorMsg(msg="Unknown iptype", routine="QuadraturePoint_Line3", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END SELECT
IF (changeLayout) THEN
- CALL ToVEFC_Line(pt)
- CALL ToVEFC_Line(wt)
+ CALL ToVEFC_Line(ans(1, 1:ncol))
+ CALL ToVEFC_Line(ans(nrow, 1:ncol))
END IF
IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromBiunitLine2Segment( &
- & xin=pt, &
- & x1=xij(:, 1), &
- & x2=xij(:, 2))
- ans(nsd + 1, :) = wt * NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP
-ELSE
- ans(1, :) = pt
- ans(nsd + 1, :) = wt
+ CALL FromBiunitLine2Segment_(xin=ans(1, 1:ncol), x1=xij(:, 1), &
+ x2=xij(:, 2), ans=ans, nrow=ii, ncol=jj)
+
+ areal = NORM2(xij(:, 2) - xij(:, 1)) / 2.0_DFP
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
END IF
-END PROCEDURE QuadraturePoint_Line3
+
+END PROCEDURE QuadraturePoint_Line1_
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Line
@@ -1177,7 +1565,7 @@
REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1)
INTEGER(I4B) :: ii, orthopol0
-orthopol0 = input(default=Monomial, option=basisType)
+orthopol0 = input(default=polyopt%Monomial, option=basisType)
firstCall0 = input(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
@@ -1203,7 +1591,7 @@
END IF
SELECT CASE (orthopol0)
-CASE (Monomial)
+CASE (polyopt%Monomial)
IF (SIZE(xij, 2) .NE. order + 1) THEN
CALL Errormsg(&
@@ -1234,168 +1622,347 @@
END PROCEDURE LagrangeGradientEvalAll_Line1
!----------------------------------------------------------------------------
-! BasisEvalAll_Line
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE HeirarchicalBasis_Line1
-TYPE(String) :: astr
-astr = UpperCase(refLine)
+MODULE PROCEDURE LagrangeGradientEvalAll_Line1_
+LOGICAL(LGT) :: firstCall0
+REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1), areal
+INTEGER(I4B) :: ii, orthopol0, indx(2), jj
+
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = 1
+!! ans(SIZE(x, 2), SIZE(xij, 2), 1)
+
+orthopol0 = input(default=polyopt%Monomial, option=basisType)
+firstCall0 = input(default=.TRUE., option=firstCall)
+
+IF (PRESENT(coeff)) THEN
+ IF (firstCall0) THEN
+
+ ! coeff = LagrangeCoeff_Line(&
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=coeff, &
+ nrow=indx(1), ncol=indx(2))
+
+ END IF
+
+ coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2)
+
+ELSE
+
+ ! coeff0 = LagrangeCoeff_Line(&
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, &
+ nrow=indx(1), ncol=indx(2))
+END IF
+
+SELECT CASE (orthopol0)
+CASE (polyopt%Monomial)
+
+#ifdef DEBUG_VER
+
+ IF (dim2 .NE. order + 1) THEN
+ CALL Errormsg(msg="size(xij, 2) is not same as order+1", &
+ routine="LagrangeGradientEvalAll_Line1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
+ END IF
+
+#endif
+
+ DO ii = 0, order
+ indx(1) = MAX(ii - 1_I4B, 0_I4B)
+ areal = REAL(ii, kind=DFP)
+ DO jj = 1, dim1
+ xx(jj, ii + 1) = areal * (x(1, jj)**(indx(1)))
+ END DO
+ END DO
-SELECT CASE (astr%chars())
-CASE ("UNIT")
- ans = EvalAllOrthopol( &
- & n=order, &
- & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), &
- & orthopol=Lobatto)
-CASE ("BIUNIT")
- ans = EvalAllOrthopol( &
- & n=order, &
- & x=xij(1, :), &
- & orthopol=Lobatto)
CASE DEFAULT
- ans = 0.0_DFP
- CALL Errormsg(&
- & msg="No case found for refline.", &
- & file=__FILE__, &
- & routine="HeirarchicalBasis_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
+
+ ! xx(1:dim1, 1:dim2) = GradientEvalAllOrthopol(n=order, x=x(1, :), &
+ CALL GradientEvalAllOrthopol_(n=order, x=x(1, :), orthopol=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=xx, nrow=dim1, ncol=dim2)
+
END SELECT
+! ans(:, :, 1) = MATMUL(xx, coeff0)
+CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx, B=coeff0)
+
+END PROCEDURE LagrangeGradientEvalAll_Line1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Line1
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Line1_(order=order, xij=xij, refLine=refLine, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE HeirarchicalBasis_Line1
!----------------------------------------------------------------------------
-! HeirarchicalGradientBasis_Line
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Line1_
+INTEGER(I4B), PARAMETER :: orient = 1
+CALL HeirarchicalBasis_Line2_(order=order, xij=xij, refLine=refLine, &
+ orient=orient, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Line1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Line2_
+CHARACTER(1) :: astr
+REAL(DFP) :: temp(SIZE(xij, 2)), o1
+INTEGER(I4B) :: ii, k
+
+o1 = REAL(orient, kind=DFP)
+astr = UpperCase(refLine(1:1))
+
+! nrow = SIZE(xij, 2)
+! ncol = order + 1
+
+SELECT CASE (astr)
+CASE ("U")
+ CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=nrow)
+ CALL EvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+CASE ("B")
+ CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=polyopt%Lobatto, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE DEFAULT
+ nrow = 0
+ ncol = 0
+END SELECT
+
+DO CONCURRENT(k=2:order, ii=1:nrow)
+ ans(ii, k + 1) = (o1**k) * ans(ii, k + 1)
+END DO
+
+END PROCEDURE HeirarchicalBasis_Line2_
+
+!----------------------------------------------------------------------------
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalGradientBasis_Line1
-TYPE(String) :: astr
-astr = UpperCase(refLine)
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL HeirarchicalGradientBasis_Line1_(order=order, xij=xij, refLine=refLine, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE HeirarchicalGradientBasis_Line1
+
+!----------------------------------------------------------------------------
+! HeirarchicalGradientBasis_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalGradientBasis_Line1_
+INTEGER(I4B), PARAMETER :: orient = 1
+CALL HeirarchicalGradientBasis_Line2_(order=order, xij=xij, refLine=refLine, &
+ orient=orient, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE HeirarchicalGradientBasis_Line1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalGradientBasis_Line2
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = SIZE(xij, 2)
+dim2 = order + 1
+dim3 = 1
+
+ALLOCATE (ans(dim1, dim2, dim3))
+
+CALL HeirarchicalGradientBasis_Line2_(order=order, xij=xij, refLine=refLine, &
+ orient=orient, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+END PROCEDURE HeirarchicalGradientBasis_Line2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalGradientBasis_Line2_
+CHARACTER(1) :: astr
+REAL(DFP) :: temp(SIZE(xij, 2)), o1
+INTEGER(I4B) :: ii, jj, k
+
+o1 = REAL(orient, kind=DFP)
+astr = UpperCase(refLine(1:1))
+
+dim3 = 1
+
+SELECT CASE (astr)
+
+CASE ("U")
+ CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=temp, tsize=dim1)
+ CALL GradientEvalAllOrthopol_(n=order, x=temp, orthopol=polyopt%Lobatto, &
+ ans=ans(:, :, 1), nrow=dim1, ncol=dim2)
+
+ DO CONCURRENT(ii=1:dim1, jj=1:dim2)
+ ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP
+ END DO
+
+CASE ("B")
+ CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), &
+ orthopol=polyopt%Lobatto, ans=ans(:, :, 1), nrow=dim1, ncol=dim2)
-SELECT CASE (astr%chars())
-CASE ("UNIT")
- ans(:, :, 1) = GradientEvalAllOrthopol( &
- & n=order, &
- & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), &
- & orthopol=Lobatto)
- ans = ans * 2.0_DFP
-CASE ("BIUNIT")
- ans(:, :, 1) = GradientEvalAllOrthopol( &
- & n=order, &
- & x=xij(1, :), &
- & orthopol=Lobatto)
CASE DEFAULT
- ans = 0.0_DFP
- CALL Errormsg(&
- & msg="No case found for refline.", &
- & file=__FILE__, &
- & routine="HeirarchicalGradientBasis_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+ dim1 = 0; dim2 = 0; dim3 = 0
RETURN
+
END SELECT
-END PROCEDURE HeirarchicalGradientBasis_Line1
+DO CONCURRENT(k=2:order, ii=1:dim1)
+ ans(ii, k + 1, 1) = (o1**(k - 1)) * ans(ii, k + 1, 1)
+END DO
+
+END PROCEDURE HeirarchicalGradientBasis_Line2_
!----------------------------------------------------------------------------
! OrthogonalBasis_Line
!----------------------------------------------------------------------------
MODULE PROCEDURE OrthogonalBasis_Line1
-INTEGER(I4B) :: ii
-TYPE(String) :: astr
+INTEGER(I4B) :: nrow, ncol
+CALL OrthogonalBasis_Line1_(order=order, xij=xij, refline=refline, &
+ basisType=basisType, ans=ans, nrow=nrow, ncol=ncol, &
+ alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE OrthogonalBasis_Line1
-ans = 0.0_DFP
-astr = UpperCase(refLine)
+!----------------------------------------------------------------------------
+! OrthogonalBasis_Line1_
+!----------------------------------------------------------------------------
-IF (basisType .EQ. Jacobi) THEN
- IF (.NOT. PRESENT(alpha) .OR. .NOT. PRESENT(beta)) THEN
- CALL Errormsg(&
- & msg="alpha and beta should be present for basisType=Jacobi", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+MODULE PROCEDURE OrthogonalBasis_Line1_
+LOGICAL(LGT) :: isok, abool
+#ifdef DEBUG_VER
+#endif
+
+CHARACTER(1) :: astr
+REAL(DFP) :: x(SIZE(xij, 2))
+
+nrow = SIZE(xij, 2)
+ncol = order + 1
+
+#ifdef DEBUG_VER
+
+ans(1:nrow, 1:ncol) = 0.0_DFP
+
+isok = basisType .EQ. polyopt%Jacobi
+
+IF (isok) THEN
+ abool = (.NOT. PRESENT(alpha)) .OR. (.NOT. PRESENT(beta))
+
+ IF (abool) THEN
+ CALL Errormsg(routine="OrthogonalBasis_Line1()", &
+ msg="alpha and beta should be present for basisType=Jacobi", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
+
END IF
-IF (basisType .EQ. Ultraspherical) THEN
- IF (.NOT. PRESENT(lambda)) THEN
- CALL Errormsg(&
- & msg="lambda should be present for basisType=Ultraspherical", &
- & file=__FILE__, &
- & routine="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
+isok = basisType .EQ. polyopt%Ultraspherical
+IF (isok) THEN
+
+ abool = .NOT. PRESENT(lambda)
+
+ IF (abool) THEN
+ CALL Errormsg(routine="OrthogonalBasis_Line1()", file=__FILE__, &
+ msg="lambda should be present for basisType=Ultraspherical", &
+ line=__LINE__, unitno=stderr)
RETURN
END IF
+
END IF
-SELECT CASE (astr%chars())
-CASE ("UNIT")
- ans = EvalAllOrthopol(&
- & n=order, &
- & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), &
- & orthopol=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+#endif
-CASE ("BIUNIT")
- ans = EvalAllOrthopol(&
- & n=order, &
- & x=xij(1, :), &
- & orthopol=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+astr = UpperCase(refLine(1:1))
+
+SELECT CASE (astr)
+CASE ("U")
+ CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=nrow)
+ CALL EvalAllOrthopol_(n=order, x=x, orthopol=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE ("B")
+ CALL EvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
CASE DEFAULT
- ans = 0.0_DFP
- CALL Errormsg(&
- & msg="No case found for refLine.", &
- & file=__FILE__, &
- & routine="OrthogonalBasis_Line1()", &
- & line=__LINE__, &
- & unitno=stderr)
+
+ ans(1:nrow, 1:ncol) = 0.0_DFP
+ CALL Errormsg(msg="No case found for refLine.", &
+ routine="OrthogonalBasis_Line1()", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
+
END SELECT
-END PROCEDURE OrthogonalBasis_Line1
+END PROCEDURE OrthogonalBasis_Line1_
!----------------------------------------------------------------------------
! OrthogonalBasisGradient_Line1
!----------------------------------------------------------------------------
MODULE PROCEDURE OrthogonalBasisGradient_Line1
-TYPE(String) :: astr
-astr = UpperCase(refLine)
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL OrthogonalBasisGradient_Line1_(order=order, xij=xij, refline=refline, &
+ basisType=basisType, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE OrthogonalBasisGradient_Line1
+
+!----------------------------------------------------------------------------
+! OrthogonalBasisGradient_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalBasisGradient_Line1_
+CHARACTER(1) :: astr
+REAL(DFP) :: x(SIZE(xij, 2))
+INTEGER(I4B) :: ii, jj
+
+astr = UpperCase(refline(1:1))
+dim1 = SIZE(xij, 2)
+dim2 = order + 1
+dim3 = 1
+
+SELECT CASE (astr)
+CASE ("U")
+
+ CALL FromUnitLine2BiUnitLine_(xin=xij(1, :), ans=x, tsize=dim1)
+ CALL GradientEvalAllOrthopol_(n=order, x=x, orthopol=basisType, &
+ ans=ans(:, :, 1), nrow=dim1, ncol=dim2)
+
+ DO CONCURRENT(ii=1:dim1, jj=1:dim2)
+ ans(ii, jj, 1) = ans(ii, jj, 1) * 2.0_DFP
+ END DO
+
+CASE ("B")
+ CALL GradientEvalAllOrthopol_(n=order, x=xij(1, :), orthopol=basisType, &
+ ans=ans(:, :, 1), nrow=dim1, ncol=dim2)
-SELECT CASE (astr%chars())
-CASE ("UNIT")
- ans(:, :, 1) = GradientEvalAllOrthopol( &
- & n=order, &
- & x=FromUnitLine2BiUnitLine(xin=xij(1, :)), &
- & orthopol=basisType)
- ans = ans * 2.0_DFP
-CASE ("BIUNIT")
- ans(:, :, 1) = GradientEvalAllOrthopol( &
- & n=order, &
- & x=xij(1, :), &
- & orthopol=basisType)
CASE DEFAULT
- ans = 0.0_DFP
- CALL Errormsg(&
- & msg="No case found for refline.", &
- & file=__FILE__, &
- & routine=" OrthogonalBasisGradient_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
+
+ ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+ CALL Errormsg(msg="No case found for refline.", &
+ routine=" OrthogonalBasisGradient_Line1_", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
+
END SELECT
-END PROCEDURE OrthogonalBasisGradient_Line1
+END PROCEDURE OrthogonalBasisGradient_Line1_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90
index 2278c25d1..c06f05c04 100644
--- a/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/LobattoPolynomialUtility@Methods.F90
@@ -16,17 +16,96 @@
!
SUBMODULE(LobattoPolynomialUtility) Methods
-USE BaseMethod
+USE Sym_LinearSolveMethods, ONLY: SymLinSolve
+
+USE LegendrePolynomialUtility, ONLY: LegendreLeadingCoeff, &
+ LegendreNormSqr, &
+ LegendreEval, &
+ LegendreEvalAll_, &
+ LegendreMonomialExpansionAll, &
+ LegendreQuadrature
+
+USE JacobiPolynomialUtility, ONLY: JacobiZeros
+
+USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalEvalAll_, &
+ UltrasphericalGradientEvalAll_, &
+ UltrasphericalGradientEvalAll
+
IMPLICIT NONE
CONTAINS
+!----------------------------------------------------------------------------
+! LobattoTransform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoTransform1_
+INTEGER(I4B) :: ii, jj, nips
+REAL(DFP) :: areal(0:n), massmat(0:n, 0:n)
+
+tsize = n + 1
+areal = 0.0_DFP
+nips = SIZE(coeff)
+
+DO jj = 0, n
+ DO ii = 0, nips - 1
+ areal(jj) = areal(jj) + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+END DO
+
+massmat = LobattoMassMatrix(n=n)
+
+CALL SymLinSolve(X=ans(0:n), A=massmat(0:n, 0:n), B=areal(0:n))
+
+END PROCEDURE LobattoTransform1_
+
+!----------------------------------------------------------------------------
+! LobattoTransform_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoTransform2_
+REAL(DFP), ALLOCATABLE :: PP(:, :)
+INTEGER(I4B) :: ii, jj, nips
+
+nips = SIZE(coeff)
+ALLOCATE (PP(nips, n + 1))
+CALL LobattoEvalAll_(n=n, x=x, ans=PP, nrow=ii, ncol=jj)
+CALL LobattoTransform_(n=n, coeff=coeff, PP=PP, w=w, quadType=quadType, &
+ ans=ans, tsize=tsize)
+DEALLOCATE (PP)
+END PROCEDURE LobattoTransform2_
+
+!----------------------------------------------------------------------------
+! LobattoTransform_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoTransform3_
+REAL(DFP) :: pt(0:n + 1), wt(0:n + 1), coeff(0:n + 1), x
+REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP
+INTEGER(I4B) :: ii, nips
+
+nips = n + 2
+CALL LegendreQuadrature(n=nips, pt=pt, wt=wt, quadType=quadType)
+!! We are using n+2 quadrature points as it works well in case of
+!! GaussLobatto quadrature points also
+
+DO ii = 0, nips - 1
+ x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2
+ x = x * half
+ coeff(ii) = f(x)
+END DO
+
+CALL LobattoTransform_(n=n, coeff=coeff, x=pt, w=wt, quadType=quadType, &
+ ans=ans, tsize=tsize)
+
+END PROCEDURE LobattoTransform3_
+
!----------------------------------------------------------------------------
! LobattoLeadingCoeff
!----------------------------------------------------------------------------
MODULE PROCEDURE LobattoLeadingCoeff
REAL(DFP) :: avar, m
- !!
+
SELECT CASE (n)
CASE (0)
ans = 0.5_DFP
@@ -117,53 +196,86 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LobattoEvalAll1
+INTEGER(I4B) :: tsize
+CALL LobattoEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE LobattoEvalAll1
+
+!----------------------------------------------------------------------------
+! LobattoEvalAll_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoEvalAll1_
REAL(DFP) :: avar, m
REAL(DFP) :: p(n + 1)
INTEGER(I4B) :: ii
- !!
+
+tsize = n + 1
+
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)
+
+ CALL LegendreEvalAll_(n=n, x=x, ans=p, tsize=ii)
+
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))
+ ans(ii + 2) = avar * (p(ii + 2) - p(ii))
END DO
+
END SELECT
-END PROCEDURE LobattoEvalAll1
+END PROCEDURE LobattoEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE LobattoEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL LobattoEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LobattoEvalAll2
+
+!----------------------------------------------------------------------------
+! LobattoEvalAll
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoEvalAll2_
REAL(DFP) :: avar, m
REAL(DFP) :: p(SIZE(x), n + 1)
-INTEGER(I4B) :: ii
+INTEGER(I4B) :: ii, aint, bint
+
+nrow = SIZE(x)
+ncol = 1 + n
+
SELECT CASE (n)
CASE (0)
- ans(:, 1) = 0.5_DFP * (1.0_DFP - x)
+ ans(1:nrow, 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)
+ ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x)
+ ans(1:nrow, 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)
+ ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x)
+ ans(1:nrow, 2) = 0.5_DFP * (1.0_DFP + x)
+ CALL LegendreEvalAll_(n=n, x=x, ans=p, nrow=aint, ncol=bint)
+
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))
+ ans(1:nrow, 2 + ii) = avar * (p(1:nrow, ii + 2) - p(1:nrow, ii))
END DO
+
END SELECT
-END PROCEDURE LobattoEvalAll2
+END PROCEDURE LobattoEvalAll2_
!----------------------------------------------------------------------------
! LobattoKernelEvalAll
@@ -276,60 +388,89 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LobattoGradientEvalAll1
+INTEGER(I4B) :: tsize
+CALL LobattoGradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE LobattoGradientEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoGradientEvalAll1_
REAL(DFP) :: p(n), avar, m
INTEGER(I4B) :: ii
- !!
+
+tsize = n + 1
+
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)
- !!
+
+ CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, tsize=ii)
+
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
+END PROCEDURE LobattoGradientEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE LobattoGradientEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL LobattoGradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LobattoGradientEvalAll2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LobattoGradientEvalAll2_
REAL(DFP) :: p(SIZE(x), n), avar, m
INTEGER(I4B) :: ii
- !!
+
+nrow = SIZE(x)
+ncol = n + 1
+
SELECT CASE (n)
CASE (0)
- ans(:, 1) = -0.5_DFP
+ ans(1:nrow, 1) = -0.5_DFP
+
CASE (1)
- ans(:, 1) = -0.5_DFP
- ans(:, 2) = 0.5_DFP
+ ans(1:nrow, 1) = -0.5_DFP
+ ans(1:nrow, 2) = 0.5_DFP
+
CASE DEFAULT
- ans(:, 1) = -0.5_DFP
- ans(:, 2) = 0.5_DFP
- !!
- p = LegendreEvalAll(n=n - 1_I4B, x=x)
- !!
+ ans(1:nrow, 1) = -0.5_DFP
+ ans(1:nrow, 2) = 0.5_DFP
+
+ CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii)
+
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(1:nrow, ii + 2) = avar * p(1:nrow, ii + 1)
! ans(3:) = p(2:)
END DO
- !!
+
END SELECT
-END PROCEDURE LobattoGradientEvalAll2
+
+END PROCEDURE LobattoGradientEvalAll2_
!----------------------------------------------------------------------------
!
@@ -446,6 +587,66 @@
END PROCEDURE LobattoStiffnessMatrix
+!----------------------------------------------------------------------------
+! Lobatto0
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Lobatto0
+ans = 0.5_DFP * (1.0_DFP - x)
+END PROCEDURE Lobatto0
+
+MODULE PROCEDURE Lobatto1
+ans = 0.5_DFP * (1.0_DFP + x)
+END PROCEDURE Lobatto1
+
+MODULE PROCEDURE Lobatto2
+REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(3.0_DFP) / SQRT(2.0_DFP)
+ans = coeff * (x**2 - 1.0_DFP)
+END PROCEDURE Lobatto2
+
+MODULE PROCEDURE Lobatto3
+REAL(DFP), PARAMETER :: coeff = 0.5_DFP * SQRT(5.0_DFP) / SQRT(2.0_DFP)
+ans = coeff * (x**2 - 1.0_DFP) * x
+END PROCEDURE Lobatto3
+
+MODULE PROCEDURE Lobatto4
+REAL(DFP), PARAMETER :: coeff = SQRT(7.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (5.0_DFP * x**2 - 1.0_DFP)
+END PROCEDURE Lobatto4
+
+MODULE PROCEDURE Lobatto5
+REAL(DFP), PARAMETER :: coeff = SQRT(9.0_DFP) / SQRT(2.0_DFP) / 8.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (7.0_DFP * x**2 - 3.0_DFP) * x
+END PROCEDURE Lobatto5
+
+MODULE PROCEDURE Lobatto6
+REAL(DFP), PARAMETER :: coeff = SQRT(11.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (21.0_DFP * x**4 - 14.0_DFP * x**2 + 1.0_DFP)
+END PROCEDURE Lobatto6
+
+MODULE PROCEDURE Lobatto7
+REAL(DFP), PARAMETER :: coeff = SQRT(13.0_DFP) / SQRT(2.0_DFP) / 16.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (33.0_DFP * x**4 - 30.0_DFP * x**2 + 5.0_DFP) * x
+END PROCEDURE Lobatto7
+
+MODULE PROCEDURE Lobatto8
+REAL(DFP), PARAMETER :: coeff = SQRT(15.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (429.0_DFP * x**6 - 495.0_DFP * x**4 &
+ + 135.0_DFP * x**2 - 5.0_DFP)
+END PROCEDURE Lobatto8
+
+MODULE PROCEDURE Lobatto9
+REAL(DFP), PARAMETER :: coeff = SQRT(17.0_DFP) / SQRT(2.0_DFP) / 128.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (715.0_DFP * x**6 - 1001.0_DFP * x**4 &
+ + 385.0_DFP * x**2 - 35.0_DFP) * x
+END PROCEDURE Lobatto9
+
+MODULE PROCEDURE Lobatto10
+REAL(DFP), PARAMETER :: coeff = SQRT(19.0_DFP) / SQRT(2.0_DFP) / 256.0_DFP
+ans = coeff * (x**2 - 1.0_DFP) * (2431.0_DFP * x**8 - 4004.0_DFP * x**6 &
+ + 2002.0_DFP * x**4 - 308.0_DFP * x**2 + 7.0_DFP)
+END PROCEDURE Lobatto10
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90
index 207d2760c..45bbc689c 100644
--- a/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/OrthogonalPolynomialUtility@Methods.F90
@@ -16,7 +16,68 @@
!
SUBMODULE(OrthogonalPolynomialUtility) Methods
-USE BaseMethod
+USE GlobalData, ONLY: stderr
+
+USE ReferenceElement_Method, ONLY: XiDimension
+
+USE InputUtility, ONLY: Input
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE BaseType, ONLY: poly => TypePolynomialOpt, &
+ elem => TypeElemNameOpt
+
+USE LagrangePolynomialUtility, ONLY: LagrangeDOF
+
+USE JacobiPolynomialUtility, ONLY: JacobiEvalAll, &
+ JacobiEvalAll_, &
+ JacobiGradientEvalAll, &
+ JacobiGradientEvalAll_
+
+USE UltrasphericalPolynomialUtility, ONLY: UltraSphericalEvalAll, &
+ UltraSphericalEvalAll_, &
+ UltraSphericalGradientEvalAll, &
+ UltraSphericalGradientEvalAll_
+
+USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1EvalAll, &
+ Chebyshev1EvalAll_, &
+ Chebyshev1GradientEvalAll, &
+ Chebyshev1GradientEvalAll_
+
+USE LegendrePolynomialUtility, ONLY: LegendreEvalAll, &
+ LegendreEvalAll_, &
+ LegendreGradientEvalAll, &
+ LegendreGradientEvalAll_
+
+USE LobattoPolynomialUtility, ONLY: LobattoEvalAll, &
+ LobattoEvalAll_, &
+ LobattoGradientEvalAll, &
+ LobattoGradientEvalAll_
+
+USE UnscaledLobattoPolynomialUtility, ONLY: UnscaledLobattoEvalAll, &
+ UnscaledLobattoEvalAll_, &
+ UnscaledLobattoGradientEvalAll, &
+ UnscaledLobattoGradientEvalAll_
+
+USE LineInterpolationUtility, ONLY: OrthogonalBasis_Line_, &
+ OrthogonalBasisGradient_Line_
+
+USE TriangleInterpolationUtility, ONLY: OrthogonalBasis_Triangle_, &
+ OrthogonalBasisGradient_Triangle_
+
+USE QuadrangleInterpolationUtility, ONLY: OrthogonalBasis_Quadrangle_, &
+ OrthogonalBasisGradient_Quadrangle_
+
+USE TetrahedronInterpolationUtility, ONLY: OrthogonalBasis_Tetrahedron_, &
+ OrthogonalBasisGradient_Tetrahedron_
+
+USE HexahedronInterpolationUtility, ONLY: OrthogonalBasis_Hexahedron_, &
+ OrthogonalBasisGradient_Hexahedron_
+
+! USE PrismInterpolationUtility, ONLY: OrthogonalBasis_Prism_
+
+! USE PyramidInterpolationUtility, ONLY: OrthogonalBasis_Pyramid_
+
IMPLICIT NONE
CONTAINS
@@ -29,8 +90,8 @@
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
@@ -51,8 +112,8 @@
REAL(DFP), DIMENSION(1:SIZE(x), 0:SIZE(c)) :: u
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
@@ -120,40 +181,226 @@
MODULE PROCEDURE EvalAllOrthopol
SELECT CASE (orthopol)
-CASE (Jacobi)
+CASE (poly%Jacobi)
ans = JacobiEvalAll(n=n, alpha=alpha, beta=beta, x=x)
-CASE (Ultraspherical)
+CASE (poly%Ultraspherical)
ans = UltraSphericalEvalAll(n=n, lambda=lambda, x=x)
-CASE (Legendre)
+CASE (poly%Legendre)
ans = LegendreEvalAll(n=n, x=x)
-CASE (Chebyshev)
+CASE (poly%Chebyshev)
ans = Chebyshev1EvalAll(n=n, x=x)
-CASE (Lobatto)
+CASE (poly%Lobatto)
ans = LobattoEvalAll(n=n, x=x)
-CASE (UnscaledLobatto)
+CASE (poly%UnscaledLobatto)
ans = UnscaledLobattoEvalAll(n=n, x=x)
END SELECT
END PROCEDURE EvalAllOrthopol
+!----------------------------------------------------------------------------
+! EvalAllOrthopol
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EvalAllOrthopol_
+SELECT CASE (orthopol)
+CASE (poly%Jacobi)
+ CALL JacobiEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, nrow=nrow, &
+ ncol=ncol)
+CASE (poly%Ultraspherical)
+ CALL UltraSphericalEvalAll_(n=n, lambda=lambda, x=x, ans=ans, nrow=nrow, &
+ ncol=ncol)
+CASE (poly%Legendre)
+ CALL LegendreEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (poly%Chebyshev)
+ CALL Chebyshev1EvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (poly%Lobatto)
+ CALL LobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (poly%UnscaledLobatto)
+ CALL UnscaledLobattoEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END SELECT
+END PROCEDURE EvalAllOrthopol_
+
!----------------------------------------------------------------------------
! GradientEvalAllOrthopol
!----------------------------------------------------------------------------
MODULE PROCEDURE GradientEvalAllOrthopol
+INTEGER(I4B) :: nrow, ncol
+CALL GradientEvalAllOrthopol_(n=n, x=x, orthopol=orthopol, ans=ans, &
+ nrow=nrow, ncol=ncol, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE GradientEvalAllOrthopol
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GradientEvalAllOrthopol_
SELECT CASE (orthopol)
-CASE (Jacobi)
- ans = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x)
-CASE (Ultraspherical)
- ans = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x)
-CASE (Legendre)
- ans = LegendreGradientEvalAll(n=n, x=x)
-CASE (Chebyshev)
- ans = Chebyshev1GradientEvalAll(n=n, x=x)
-CASE (Lobatto)
- ans = LobattoGradientEvalAll(n=n, x=x)
-CASE (UnscaledLobatto)
- ans = UnscaledLobattoGradientEvalAll(n=n, x=x)
+CASE (poly%Jacobi)
+ ! ans(1:nrow, 1:ncol) = JacobiGradientEvalAll(n=n, alpha=alpha, beta=beta, x=x)
+ CALL JacobiGradientEvalAll_(n=n, alpha=alpha, beta=beta, x=x, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+CASE (poly%Ultraspherical)
+ ! ans(1:nrow, 1:ncol) = UltraSphericalGradientEvalAll(n=n, lambda=lambda, x=x)
+ CALL UltraSphericalGradientEvalAll_(n=n, lambda=lambda, x=x, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+CASE (poly%Legendre)
+ ! ans(1:nrow, 1:ncol) = LegendreGradientEvalAll(n=n, x=x)
+ CALL LegendreGradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (poly%Chebyshev)
+ ! ans(1:nrow, 1:ncol) = Chebyshev1GradientEvalAll(n=n, x=x)
+ CALL Chebyshev1GradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (poly%Lobatto)
+ ! ans(1:nrow, 1:ncol) = LobattoGradientEvalAll(n=n, x=x)
+ CALL LobattoGradientEvalAll_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (poly%UnscaledLobatto)
+ ! ans(1:nrow, 1:ncol) = UnscaledLobattoGradientEvalAll(n=n, x=x)
+ CALL UnscaledLobattoGradientEvalAll_(n=n, x=x, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
END SELECT
-END PROCEDURE GradientEvalAllOrthopol
+END PROCEDURE GradientEvalAllOrthopol_
+
+!----------------------------------------------------------------------------
+! OrthogonalEvalAll
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalEvalAll
+INTEGER(I4B) :: nrow, ncol
+nrow = SIZE(xij, 2)
+ncol = LagrangeDOF(order=order, elemType=elemType)
+ALLOCATE (ans(nrow, ncol))
+CALL OrthogonalEvalAll_(order=order, elemType=elemType, xij=xij, &
+ domainName=domainName, basisType=basisType, ans=ans, nrow=nrow, &
+ ncol=ncol, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE OrthogonalEvalAll
+
+!----------------------------------------------------------------------------
+! OrthogonalEvalAll_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalEvalAll_
+SELECT CASE (elemType)
+
+CASE (elem%Line)
+
+ CALL OrthogonalBasis_Line_(order=order, xij=xij, &
+ refLine=domainName, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (elem%Triangle)
+
+ CALL OrthogonalBasis_Triangle_(order=order, xij=xij, &
+ reftriangle=domainName, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (elem%Quadrangle)
+
+ CALL OrthogonalBasis_Quadrangle_(p=order, q=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, basisType1=basisType, &
+ basisType2=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, &
+ alpha2=alpha, beta2=beta, lambda2=lambda)
+
+CASE (elem%Tetrahedron)
+
+ CALL OrthogonalBasis_Tetrahedron_(order=order, xij=xij, &
+ refTetrahedron=domainName, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (elem%Hexahedron)
+
+ CALL OrthogonalBasis_Hexahedron_(p=order, q=order, r=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol, &
+ basisType1=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, &
+ basisType2=basisType, alpha2=alpha, beta2=beta, lambda2=lambda, &
+ basisType3=basisType, alpha3=alpha, beta3=beta, lambda3=lambda)
+
+CASE DEFAULT
+
+ CALL ErrorMsg(msg="No case found for topology", &
+ routine='OrthogonalEvalAll_()', &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ RETURN
+
+END SELECT
+
+END PROCEDURE OrthogonalEvalAll_
+
+!----------------------------------------------------------------------------
+! OrthogonalGradientEvalAll
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalGradientEvalAll
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = SIZE(xij, 2)
+dim2 = LagrangeDOF(order=order, elemType=elemType)
+dim3 = XiDimension(elemType)
+ALLOCATE (ans(dim1, dim2, dim3))
+
+CALL OrthogonalGradientEvalAll_(order, elemType, xij, domainName, basisType, &
+ ans, dim1, dim2, dim3, alpha, beta, lambda)
+
+END PROCEDURE OrthogonalGradientEvalAll
+
+!----------------------------------------------------------------------------
+! OrthogonalGradientEvalAll_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalGradientEvalAll_
+
+SELECT CASE (elemType)
+
+CASE (elem%Line)
+
+ CALL OrthogonalBasisGradient_Line_(order=order, xij=xij, &
+ refLine=domainName, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+CASE (elem%Triangle)
+
+ CALL OrthogonalBasisGradient_Triangle_(order=order, xij=xij, &
+ reftriangle=domainName, ans=ans, tsize1=dim1, tsize2=dim2, tsize3=dim3)
+
+CASE (elem%Quadrangle)
+
+ CALL OrthogonalBasisGradient_Quadrangle_(p=order, q=order, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, basisType1=basisType, &
+ basisType2=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, &
+ alpha2=alpha, beta2=beta, lambda2=lambda)
+
+CASE (elem%Tetrahedron)
+
+ CALL OrthogonalBasisGradient_Tetrahedron_(order=order, xij=xij, &
+ refTetrahedron=domainName, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+CASE (elem%Hexahedron)
+
+ CALL OrthogonalBasisGradient_Hexahedron_(p=order, q=order, r=order, &
+ xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ basisType1=basisType, alpha1=alpha, beta1=beta, lambda1=lambda, &
+ basisType2=basisType, alpha2=alpha, beta2=beta, lambda2=lambda, &
+ basisType3=basisType, alpha3=alpha, beta3=beta, lambda3=lambda)
+
+CASE DEFAULT
+
+ CALL ErrorMsg(msg="No case found for topology", &
+ routine='OrthogonalGradientEvalAll_()', &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ RETURN
+
+END SELECT
+END PROCEDURE OrthogonalGradientEvalAll_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90
index 89c49dfe6..921320e47 100644
--- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90
@@ -102,6 +102,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Prism
+INTEGER(I4B) :: nrow, ncol
+nrow = 3
+ncol = LagrangeDOF_Prism(order=order)
+ALLOCATE (ans(nrow, ncol))
+CALL EquidistancePoint_Prism_(order=order, ans=ans, nrow=nrow, ncol=ncol, &
+ xij=xij)
+END PROCEDURE EquidistancePoint_Prism
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Prism_
! nodecoord( :, 1 ) = [0,0,-1]
! nodecoord( :, 2 ) = [1,0,-1]
! nodecoord( :, 3 ) = [0,1,-1]
@@ -109,7 +122,9 @@
! nodecoord( :, 5 ) = [1,0,1]
! nodecoord( :, 6 ) = [0,1,1]
!ISSUE: #160 Implement EquidistancePoint_Prism routine
-END PROCEDURE EquidistancePoint_Prism
+nrow = 3
+ncol = LagrangeDOF_Prism(order=order)
+END PROCEDURE EquidistancePoint_Prism_
!----------------------------------------------------------------------------
! EquidistanceInPoint_Prism
@@ -134,18 +149,27 @@
END SELECT
END PROCEDURE InterpolationPoint_Prism
+!----------------------------------------------------------------------------
+! InterpolationPoint_Prism
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Prism_
+CALL ErrorMsg(&
+ & msg="InterpolationPoint_Prism_ is not implemented", &
+ & file=__FILE__, &
+ & routine="InterpolationPoint_Prism_", &
+ & line=__LINE__, &
+ & unitno=stderr)
+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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Prism1_(order=order, i=i, xij=xij, ans=ans, &
+ tsize=tsize)
END PROCEDURE LagrangeCoeff_Prism1
!----------------------------------------------------------------------------
@@ -153,12 +177,9 @@
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Prism2_(order=order, i=i, v=v, &
+ isVandermonde=.TRUE., ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Prism2
!----------------------------------------------------------------------------
@@ -166,9 +187,9 @@
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Prism3_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Prism3
!----------------------------------------------------------------------------
@@ -176,10 +197,74 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Prism4
-ans = LagrangeVandermonde(order=order, xij=xij, elemType=Prism)
-CALL GetInvMat(ans)
+INTEGER(I4B) :: nrow, ncol
+
+CALL LagrangeCoeff_Prism4_(order=order, xij=xij, basisType=basisType, &
+ refPrism=refPrism, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
END PROCEDURE LagrangeCoeff_Prism4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Prism1_
+REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
+INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
+INTEGER(I4B) :: info, nrow, ncol
+
+tsize = SIZE(xij, 2)
+
+ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Prism, &
+ ans=V, nrow=nrow, ncol=ncol)
+
+CALL GetLU(A=V, IPIV=ipiv, info=info)
+
+CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Prism1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Prism2_
+REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp
+INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+
+vtemp = v; ans(1:tsize) = 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(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Prism2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Prism3_
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Prism3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Prism4_
+CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol, elemType=Prism)
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Prism4_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Prism
!----------------------------------------------------------------------------
@@ -241,43 +326,67 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Prism1
-! FIX: Implement LagrangeEvalAll_Prism1
-CALL ErrorMsg(&
-& msg="Work in progress", &
-& unitno=stdout, &
-& line=__LINE__, &
-& routine="LagrangeEvalAll_Prism1()", &
-& file=__FILE__)
+INTEGER(I4B) :: tsize
+CALL LagrangeEvalAll_Prism1_(order=order, x=x, xij=xij, ans=ans, &
+ tsize=tsize, refPrism=refPrism, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
END PROCEDURE LagrangeEvalAll_Prism1
!----------------------------------------------------------------------------
! LagrangeEvalAll_Prism
!----------------------------------------------------------------------------
+MODULE PROCEDURE LagrangeEvalAll_Prism1_
+! FIX: Implement LagrangeEvalAll_Prism1
+CALL ErrorMsg(msg="Work in progress", routine="LagrangeEvalAll_Prism1_()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+END PROCEDURE LagrangeEvalAll_Prism1_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Prism
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE LagrangeEvalAll_Prism2
-! FIX: Implement LagrangeEvalAll_Prism2
-CALL ErrorMsg(&
-& msg="Work in progress", &
-& unitno=stdout, &
-& line=__LINE__, &
-& routine="LagrangeEvalAll_Prism2()", &
-& file=__FILE__)
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll_Prism2_(order=order, x=x, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol, refPrism=refPrism, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
END PROCEDURE LagrangeEvalAll_Prism2
!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Prism
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Prism2_
+! FIX: Implement LagrangeEvalAll_Prism2
+CALL ErrorMsg(msg="Work in progress", routine="LagrangeEvalAll_Prism2_()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+END PROCEDURE LagrangeEvalAll_Prism2_
+
+!----------------------------------------------------------------------------
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll_Prism1
-!FIX: Implement LagrangeGradientEvalAll_Prism1
-CALL ErrorMsg(&
-& msg="Work in progress", &
-& unitno=stdout, &
-& line=__LINE__, &
-& routine="LagrangeGradientEvalAll_Prism1()", &
-& file=__FILE__)
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll_Prism1_(order=order, x=x, xij=xij, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3, refPrism=refPrism, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
END PROCEDURE LagrangeGradientEvalAll_Prism1
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Prism
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Prism1_
+!FIX: Implement LagrangeGradientEvalAll_Prism1_
+CALL ErrorMsg(msg="Work in progress", &
+ routine="LagrangeGradientEvalAll_Prism1_()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+RETURN
+END PROCEDURE LagrangeGradientEvalAll_Prism1_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90
index ccbdb15b7..93585e06e 100644
--- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90
@@ -53,12 +53,9 @@
MODULE PROCEDURE RefElemDomain_Pyramid
!FIX: Implement RefElemDomain
-CALL Errormsg(&
- & msg="[WORK IN PROGRESS] We are working on it", &
- & file=__FILE__, &
- & line=__LINE__,&
- & routine="RefElemDomain_Pyramid()", &
- & unitno=stderr)
+CALL Errormsg(msg="[WORK IN PROGRESS] We are working on it", &
+ routine="RefElemDomain_Pyramid()", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
END PROCEDURE RefElemDomain_Pyramid
!----------------------------------------------------------------------------
@@ -102,18 +99,31 @@
END PROCEDURE GetTotalInDOF_Pyramid
!----------------------------------------------------------------------------
-! EquidistancePoint_Pyramid
+! EquidistancePoint_Prism
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Pyramid
-!FIX: Implement EquidistancePoint_Pyramid
-!ISSUE: #161 Implement EquidistancePoint_Pyramid routine
+INTEGER(I4B) :: nrow, ncol
+nrow = 3
+ncol = LagrangeDOF_Pyramid(order=order)
+ALLOCATE (ans(nrow, ncol))
+CALL EquidistancePoint_Pyramid_(order=order, ans=ans, nrow=nrow, ncol=ncol, &
+ xij=xij)
+END PROCEDURE EquidistancePoint_Pyramid
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Pyramid_
+nrow = 3
+ncol = LagrangeDOF_Pyramid(order=order)
! nodecoord(:, 1) = [-1, -1, 0]
! nodecoord(:, 2) = [1, -1, 0]
! nodecoord(:, 3) = [1, 1, 0]
! nodecoord(:, 4) = [-1, 1, 0]
! nodecoord(:, 5) = [0, 0, 1]
-END PROCEDURE EquidistancePoint_Pyramid
+END PROCEDURE EquidistancePoint_Pyramid_
!----------------------------------------------------------------------------
! EquidistanceInPoint_Pyramid
@@ -122,7 +132,6 @@
MODULE PROCEDURE EquidistanceInPoint_Pyramid
! FIX: Implement EquidistanceInPoint_Pyramid
! ISSUE: #161 Implement EquidistanceInPoint_Pyramid routine
-
END PROCEDURE EquidistanceInPoint_Pyramid
!----------------------------------------------------------------------------
@@ -141,18 +150,27 @@
END SELECT
END PROCEDURE InterpolationPoint_Pyramid
+!----------------------------------------------------------------------------
+! InterpolationPoint_Pyramid
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Pyramid_
+CALL ErrorMsg(&
+ & msg="InterpolationPoint_Pyramid_ is not implemented", &
+ & file=__FILE__, &
+ & routine="InterpolationPoint_Pyramid_", &
+ & line=__LINE__, &
+ & unitno=stderr)
+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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Pyramid1_(order=order, i=i, xij=xij, ans=ans, &
+ tsize=tsize)
END PROCEDURE LagrangeCoeff_Pyramid1
!----------------------------------------------------------------------------
@@ -160,12 +178,9 @@
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Pyramid2_(order=order, i=i, v=v, &
+ isVandermonde=.TRUE., ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Pyramid2
!----------------------------------------------------------------------------
@@ -173,9 +188,9 @@
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Pyramid3_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Pyramid3
!----------------------------------------------------------------------------
@@ -183,10 +198,74 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Pyramid4
-ans = LagrangeVandermonde(order=order, xij=xij, elemType=Pyramid)
-CALL GetInvMat(ans)
+INTEGER(I4B) :: nrow, ncol
+
+CALL LagrangeCoeff_Pyramid4_(order=order, xij=xij, basisType=basisType, &
+ refPyramid=refPyramid, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
END PROCEDURE LagrangeCoeff_Pyramid4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Pyramid1_
+REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
+INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
+INTEGER(I4B) :: info, nrow, ncol
+
+tsize = SIZE(xij, 2)
+
+ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Pyramid, &
+ ans=V, nrow=nrow, ncol=ncol)
+
+CALL GetLU(A=V, IPIV=ipiv, info=info)
+
+CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Pyramid1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Pyramid2_
+REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp
+INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+
+vtemp = v; ans(1:tsize) = 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(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Pyramid2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Pyramid3_
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Pyramid3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Pyramid4_
+CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol, elemType=Pyramid)
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Pyramid4_
+
!----------------------------------------------------------------------------
! QuadraturePoint_Pyramid
!----------------------------------------------------------------------------
@@ -248,41 +327,64 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Pyramid1
-!FIX: LagrangeEvalAll_Pyramid1
-CALL ErrorMsg(&
-& msg="Work in progress", &
-& unitno=stdout, &
-& line=__LINE__, &
-& routine="LagrangeEvalAll_Pyramid1()", &
-& file=__FILE__)
+INTEGER(I4B) :: tsize
+
END PROCEDURE LagrangeEvalAll_Pyramid1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Pyramid1_
+!FIX: LagrangeEvalAll_Pyramid1
+CALL ErrorMsg(msg="Work in progress", routine="LagrangeEvalAll_Pyramid1()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+END PROCEDURE LagrangeEvalAll_Pyramid1_
+
!----------------------------------------------------------------------------
! LagrangeEvalAll_Pyramid
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Pyramid2
-!FIX: LagrangeEvalAll_Pyramid2
-CALL ErrorMsg(&
-& msg="Work in progress", &
-& unitno=stdout, &
-& line=__LINE__, &
-& routine="LagrangeEvalAll_Pyramid2()", &
-& file=__FILE__)
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll_Pyramid2_(order=order, x=x, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol, refPyramid=refPyramid, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
END PROCEDURE LagrangeEvalAll_Pyramid2
!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Pyramid
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Pyramid2_
+!FIX: LagrangeEvalAll_Pyramid2
+CALL ErrorMsg(msg="Work in progress", unitno=stdout, line=__LINE__, &
+ routine="LagrangeEvalAll_Pyramid2()", file=__FILE__)
+END PROCEDURE LagrangeEvalAll_Pyramid2_
+
+!----------------------------------------------------------------------------
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll_Pyramid1
-!FIX: LagrangeGradientEvalAll_Pyramid1
-CALL ErrorMsg(&
-& msg="Work in progress", &
-& unitno=stdout, &
-& line=__LINE__, &
-& routine="LagrangeGradientEvalAll_Pyramid1()", &
-& file=__FILE__)
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll_Pyramid1_(order=order, x=x, xij=xij, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3, refPyramid=refPyramid, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
END PROCEDURE LagrangeGradientEvalAll_Pyramid1
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Pyramid
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Pyramid1_
+!FIX: Implement LagrangeGradientEvalAll_Pyramid1_
+CALL ErrorMsg(msg="Work in progress", &
+ routine="LagrangeGradientEvalAll_Pyramid1_()", &
+ unitno=stdout, line=__LINE__, file=__FILE__)
+RETURN
+END PROCEDURE LagrangeGradientEvalAll_Pyramid1_
+
END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90
index 31abd7661..32243f79b 100644
--- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90
@@ -32,33 +32,10 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FacetConnectivity_Quadrangle
-CHARACTER(:), ALLOCATABLE :: baseInterpol0
-! TYPE(String) :: baseContinuity0
-
-baseInterpol0 = UpperCase(baseInterpol)
-! baseContinuity0 = UpperCase(baseContinuity)
-
-SELECT CASE (baseInterpol0)
-CASE ( &
- & "HIERARCHYPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHYPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION", &
- & "ORTHOGONALPOLYNOMIAL", &
- & "ORTHOGONAL", &
- & "ORTHOGONALINTERPOLATION")
- ans(:, 1) = [1, 2]
- ans(:, 2) = [4, 3]
- ans(:, 3) = [1, 4]
- ans(:, 4) = [2, 3]
-CASE DEFAULT
- ans(:, 1) = [1, 2]
- ans(:, 2) = [2, 3]
- ans(:, 3) = [3, 4]
- ans(:, 4) = [4, 1]
-END SELECT
+ans(1:2, 1) = [1, 2]
+ans(1:2, 2) = [2, 3]
+ans(1:2, 3) = [3, 4]
+ans(1:2, 4) = [4, 1]
END PROCEDURE FacetConnectivity_Quadrangle
!----------------------------------------------------------------------------
@@ -75,37 +52,52 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeDegree_Quadrangle1
-INTEGER(I4B) :: n, ii, jj, kk
-n = LagrangeDOF_Quadrangle(order=order)
-ALLOCATE (ans(n, 2))
-kk = 0
-DO jj = 0, order
- DO ii = 0, order
- kk = kk + 1
- ans(kk, 1) = ii
- ans(kk, 2) = jj
- END DO
-END DO
+INTEGER(I4B) :: nrow, ncol
+nrow = LagrangeDOF_Quadrangle(order=order)
+ALLOCATE (ans(nrow, 2))
+CALL LagrangeDegree_Quadrangle1_(ans=ans, nrow=nrow, ncol=ncol, order=order)
END PROCEDURE LagrangeDegree_Quadrangle1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Quadrangle1_
+CALL LagrangeDegree_Quadrangle2_(ans=ans, p=order, q=order, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE LagrangeDegree_Quadrangle1_
+
!----------------------------------------------------------------------------
! LagrangeDegree_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeDegree_Quadrangle2
-INTEGER(I4B) :: n, ii, jj, kk
-n = LagrangeDOF_Quadrangle(p=p, q=q)
-ALLOCATE (ans(n, 2))
-kk = 0
-DO jj = 0, q
- DO ii = 0, p
- kk = kk + 1
- ans(kk, 1) = ii
- ans(kk, 2) = jj
- END DO
-END DO
+INTEGER(I4B) :: nrow, ncol
+
+nrow = LagrangeDOF_Quadrangle(p=p, q=q)
+ALLOCATE (ans(nrow, 2))
+CALL LagrangeDegree_Quadrangle2_(ans=ans, nrow=nrow, ncol=ncol, &
+ p=p, q=q)
END PROCEDURE LagrangeDegree_Quadrangle2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Quadrangle2_
+INTEGER(I4B) :: ii, jj, p1
+
+nrow = LagrangeDOF_Quadrangle(p=p, q=q)
+ncol = 2
+p1 = p + 1
+
+DO CONCURRENT(jj=0:q, ii=0:p)
+ ans(p1 * jj + ii + 1, 1) = ii
+ ans(p1 * jj + ii + 1, 2) = jj
+END DO
+
+END PROCEDURE LagrangeDegree_Quadrangle2_
+
!----------------------------------------------------------------------------
! GetTotalDOF_Quadrangle
!----------------------------------------------------------------------------
@@ -118,9 +110,17 @@
! GetTotalInDOF_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetTotalInDOF_Quadrangle
+MODULE PROCEDURE GetTotalInDOF_Quadrangle1
ans = (order - 1)**2
-END PROCEDURE GetTotalInDOF_Quadrangle
+END PROCEDURE GetTotalInDOF_Quadrangle1
+
+!----------------------------------------------------------------------------
+! GetTotalInDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalInDOF_Quadrangle2
+ans = (p - 1) * (q - 1)
+END PROCEDURE GetTotalInDOF_Quadrangle2
!----------------------------------------------------------------------------
! LagrangeDOF_Quadrangle
@@ -159,210 +159,111 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Quadrangle1
-INTEGER(I4B) :: nsd, n, ne, i1, i2
-REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu
+INTEGER(I4B) :: nrow, ncol
-x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- x(1:nsd, 1:4) = xij(1:nsd, 1:4)
+ nrow = SIZE(xij, 1)
ELSE
- nsd = 2_I4B
- x = 0.0_DFP
- x(1:2, :) = RefQuadrangleCoord("BIUNIT")
+ nrow = 2_I4B
END IF
-n = LagrangeDOF_Quadrangle(order=order)
-ALLOCATE (ans(nsd, n))
-ans = 0.0_DFP
-
-! points on vertex
-ans(1:nsd, 1:4) = x(1:nsd, 1:4)
-
-! points on edge
-ne = LagrangeInDOF_Line(order=order)
-
-i2 = 4
-IF (order .GT. 1_I4B) THEN
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [1, 2]))
-
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [2, 3]))
-
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [3, 4]))
-
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [4, 1]))
+ncol = LagrangeDOF_Quadrangle(order=order)
-END IF
+ALLOCATE (ans(nrow, ncol))
-! points on face
-IF (order .GT. 1_I4B) THEN
+CALL EquidistancePoint_Quadrangle1_(order=order, ans=ans, nrow=nrow, &
+ ncol=ncol, xij=xij)
- IF (order .EQ. 2_I4B) THEN
- i1 = i2 + 1
- ans(1:nsd, i1) = SUM(x(1:nsd, :), dim=2_I4B) / 4.0_DFP
- ELSE
+END PROCEDURE EquidistancePoint_Quadrangle1
- e1 = x(:, 2) - x(:, 1)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 4) - x(:, 1)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- e1 = x(:, 3) - x(:, 2)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 1) - x(:, 2)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- e1 = x(:, 2) - x(:, 3)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 4) - x(:, 3)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- e1 = x(:, 3) - x(:, 4)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 1) - x(:, 4)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- i1 = i2 + 1
- ans(1:nsd, i1:) = EquidistancePoint_Quadrangle( &
- & order=order - 2, &
- & xij=xin(1:nsd, 1:4))
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
- END IF
-END IF
-END PROCEDURE EquidistancePoint_Quadrangle1
+MODULE PROCEDURE EquidistancePoint_Quadrangle1_
+CALL EquidistancePoint_Quadrangle2_(p=order, q=order, ans=ans, nrow=nrow, &
+ ncol=ncol, xij=xij)
+END PROCEDURE EquidistancePoint_Quadrangle1_
!----------------------------------------------------------------------------
! EquidistancePoint_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Quadrangle2
-ans = InterpolationPoint_Quadrangle2( &
- & p=p, &
- & q=q, &
- & xij=xij, &
- & ipType1=Equidistance, &
- & ipType2=Equidistance, &
- & layout="VEFC")
+INTEGER(I4B) :: nrow, ncol
+nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1)
+ncol = (p + 1) * (q + 1)
+ALLOCATE (ans(nrow, ncol))
+CALL EquidistancePoint_Quadrangle2_(p=p, q=q, ans=ans, nrow=nrow, ncol=ncol, &
+ xij=xij)
END PROCEDURE EquidistancePoint_Quadrangle2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Quadrangle2_
+CALL InterpolationPoint_Quadrangle2_(p=p, q=q, ipType1=Equidistance, &
+ ipType2=Equidistance, ans=ans, nrow=nrow, ncol=ncol, layout="VEFC", xij=xij)
+END PROCEDURE EquidistancePoint_Quadrangle2_
+
!----------------------------------------------------------------------------
! EquidistanceInPoint_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistanceInPoint_Quadrangle1
-INTEGER(I4B) :: nsd, n, ne, i1, i2
-REAL(DFP) :: x(3, 4), xin(3, 4), e1(3), e2(3), lam, avar, mu
+INTEGER(I4B) :: nrow, ncol
-IF (order .LT. 2_I4B) THEN
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2
+END IF
+
+ncol = LagrangeInDOF_Quadrangle(order=order)
+
+IF (ncol .EQ. 0) THEN
ALLOCATE (ans(0, 0))
RETURN
+ELSE
+ ALLOCATE (ans(nrow, ncol))
+ ans(1:nrow, 1:ncol) = EquidistanceInPoint_Quadrangle2(p=order, q=order, &
+ xij=xij)
END IF
+END PROCEDURE EquidistanceInPoint_Quadrangle1
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Quadrangle2
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+INTEGER(I4B) :: a, b, nrow, ncol
-x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP
+a = LagrangeDOF_Quadrangle(p=p, q=q)
+b = LagrangeInDOF_Quadrangle(p=p, q=q)
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- x(1:nsd, 1:4) = xij(1:nsd, 1:4)
+ nrow = SIZE(xij, 1)
ELSE
- nsd = 2_I4B
- x(1:nsd, 1) = [-1.0, -1.0]
- x(1:nsd, 2) = [1.0, -1.0]
- x(1:nsd, 3) = [1.0, 1.0]
- x(1:nsd, 4) = [-1.0, 1.0]
+ nrow = 2
END IF
-n = LagrangeInDOF_Quadrangle(order=order)
-ALLOCATE (ans(nsd, n))
-ans = 0.0_DFP
+ALLOCATE (temp(nrow, a))
-! points on face
-IF (order .EQ. 2_I4B) THEN
- ans(1:nsd, 1) = SUM(x, dim=2_I4B) / 4.0_DFP
+CALL EquidistancePoint_Quadrangle2_(p=p, q=q, xij=xij, ans=temp, &
+ nrow=nrow, ncol=ncol)
+
+IF (b .EQ. 0) THEN
+ ALLOCATE (ans(0, 0))
ELSE
- e1 = x(:, 2) - x(:, 1)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 4) - x(:, 1)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- e1 = x(:, 3) - x(:, 2)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 1) - x(:, 2)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- e1 = x(:, 2) - x(:, 3)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 4) - x(:, 3)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- e1 = x(:, 3) - x(:, 4)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 1) - x(:, 4)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 4) = x(1:nsd, 4) + lam * e1(1:nsd) + mu * e2(1:nsd)
-
- ans(1:nsd, 1:) = EquidistancePoint_Quadrangle1( &
- & order=order - 2, &
- & xij=xin(1:nsd, 1:4))
+ ALLOCATE (ans(nrow, b))
+ ans(1:nrow, 1:b) = temp(1:nrow, a - b + 1:)
END IF
-END PROCEDURE EquidistanceInPoint_Quadrangle1
-!----------------------------------------------------------------------------
-! EquidistanceInPoint_Quadrangle
-!----------------------------------------------------------------------------
+DEALLOCATE (temp)
-MODULE PROCEDURE EquidistanceInPoint_Quadrangle2
END PROCEDURE EquidistanceInPoint_Quadrangle2
!----------------------------------------------------------------------------
@@ -377,170 +278,243 @@
!
!----------------------------------------------------------------------------
+PURE SUBROUTINE GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, &
+ startNode)
+ INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :)
+ INTEGER(I4B), INTENT(OUT) :: pointsOrder(:)
+ INTEGER(I4B), INTENT(IN) :: startNode
+
+ SELECT CASE (startNode)
+ CASE (1)
+ edgeConnectivity(1:2, 1) = [1, 2]
+ edgeConnectivity(1:2, 2) = [2, 3]
+ edgeConnectivity(1:2, 3) = [3, 4]
+ edgeConnectivity(1:2, 4) = [4, 1]
+ pointsOrder = [1, 2, 3, 4]
+ CASE (2)
+ edgeConnectivity(1:2, 1) = [2, 3]
+ edgeConnectivity(1:2, 2) = [3, 4]
+ edgeConnectivity(1:2, 3) = [4, 1]
+ edgeConnectivity(1:2, 4) = [1, 2]
+ pointsOrder = [2, 3, 4, 1]
+ CASE (3)
+ edgeConnectivity(1:2, 1) = [3, 4]
+ edgeConnectivity(1:2, 2) = [4, 1]
+ edgeConnectivity(1:2, 3) = [1, 2]
+ edgeConnectivity(1:2, 4) = [2, 3]
+ pointsOrder = [3, 4, 1, 2]
+ CASE (4)
+ edgeConnectivity(1:2, 1) = [4, 1]
+ edgeConnectivity(1:2, 2) = [1, 2]
+ edgeConnectivity(1:2, 3) = [2, 3]
+ edgeConnectivity(1:2, 4) = [3, 4]
+ pointsOrder = [4, 1, 2, 3]
+ END SELECT
+
+END SUBROUTINE GetEdgeConnectivityHelpAntiClock
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, &
+ startNode)
+ INTEGER(I4B), INTENT(INOUT) :: edgeConnectivity(:, :)
+ INTEGER(I4B), INTENT(OUT) :: pointsOrder(:)
+ INTEGER(I4B), INTENT(IN) :: startNode
+
+ SELECT CASE (startNode)
+ CASE (1)
+ edgeConnectivity(1:2, 1) = [1, 4]
+ edgeConnectivity(1:2, 2) = [4, 3]
+ edgeConnectivity(1:2, 3) = [3, 2]
+ edgeConnectivity(1:2, 4) = [2, 1]
+ pointsOrder = [1, 4, 3, 2]
+ CASE (2)
+ edgeConnectivity(1:2, 1) = [2, 1]
+ edgeConnectivity(1:2, 2) = [1, 4]
+ edgeConnectivity(1:2, 3) = [4, 3]
+ edgeConnectivity(1:2, 4) = [3, 2]
+ pointsOrder = [2, 1, 4, 3]
+ CASE (3)
+ edgeConnectivity(1:2, 1) = [3, 2]
+ edgeConnectivity(1:2, 2) = [2, 1]
+ edgeConnectivity(1:2, 3) = [1, 4]
+ edgeConnectivity(1:2, 4) = [4, 3]
+ pointsOrder = [3, 2, 1, 4]
+ CASE (4)
+ edgeConnectivity(1:2, 1) = [4, 3]
+ edgeConnectivity(1:2, 2) = [3, 2]
+ edgeConnectivity(1:2, 3) = [2, 1]
+ edgeConnectivity(1:2, 4) = [1, 4]
+ pointsOrder = [4, 3, 2, 1]
+ END SELECT
+
+END SUBROUTINE GetEdgeConnectivityHelpClock
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise
! internal variables
-INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2
+INTEGER(I4B) :: cnt, m, ii, jj, ll, N, ij(2, 4), iedge, p1, p2
INTEGER(I4B), PARAMETER :: tEdges = 4
INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, &
-& pointsOrder(4)
-REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), &
- & temp_in(:, :)
+ pointsOrder(4)
+REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), &
+ temp_in(:, :)
+
+LOGICAL(LGT) :: isok, abool
! vertices
N = (p + 1) * (q + 1)
cnt = 0
ll = -1
-SELECT CASE (startNode)
-CASE (1)
- edgeConnectivity(:, 1) = [1, 4]
- edgeConnectivity(:, 2) = [4, 3]
- edgeConnectivity(:, 3) = [3, 2]
- edgeConnectivity(:, 4) = [2, 1]
- pointsOrder = [1, 4, 3, 2]
-CASE (2)
- edgeConnectivity(:, 1) = [2, 1]
- edgeConnectivity(:, 2) = [1, 4]
- edgeConnectivity(:, 3) = [4, 3]
- edgeConnectivity(:, 4) = [3, 2]
- pointsOrder = [2, 1, 4, 3]
-CASE (3)
- edgeConnectivity(:, 1) = [3, 2]
- edgeConnectivity(:, 2) = [2, 1]
- edgeConnectivity(:, 3) = [1, 4]
- edgeConnectivity(:, 4) = [4, 3]
- pointsOrder = [3, 2, 1, 4]
-CASE (4)
- edgeConnectivity(:, 1) = [4, 3]
- edgeConnectivity(:, 2) = [3, 2]
- edgeConnectivity(:, 3) = [2, 1]
- edgeConnectivity(:, 4) = [1, 4]
- pointsOrder = [4, 3, 2, 1]
-END SELECT
+CALL GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, startNode)
-IF (ALL([p, q] .EQ. 0_I4B)) THEN
- temp(:, 1) = [xi(1, 1), eta(1, 1)]
+isok = (p .EQ. 0) .AND. (q .EQ. 0)
+IF (isok) THEN
+ temp(1, 1) = xi(1, 1)
+ temp(2, 1) = eta(1, 1)
RETURN
END IF
-ij(:, 1) = [1, 1]
-ij(:, 2) = [p + 1, 1]
-ij(:, 3) = [p + 1, q + 1]
-ij(:, 4) = [1, q + 1]
+! INFO: This case is p = 0 and q .GE. 1
+abool = (p .EQ. 0) .AND. (q .GE. 1)
+IF (abool) THEN
+ DO jj = 1, q + 1
+ cnt = cnt + 1
+ temp(1, jj) = xi(1, jj)
+ temp(2, jj) = eta(1, jj)
+ END DO
+ RETURN
+END IF
-IF (ALL([p, q] .GE. 1_I4B)) THEN
- DO ii = 1, 4
+! INFO: This case is q = 0 and p .GE. 1
+abool = (q .EQ. 0) .AND. (p .GE. 1)
+IF (abool) THEN
+ DO ii = 1, p + 1
cnt = cnt + 1
- jj = pointsOrder(ii)
- temp(1:2, ii) = [ &
- & xi(ij(1, jj), ij(2, jj)), &
- & eta(ij(1, jj), ij(2, jj)) &
- & ]
+ temp(1, ii) = xi(ii, 1)
+ temp(2, ii) = eta(ii, 1)
END DO
- IF (ALL([p, q] .EQ. 1_I4B)) RETURN
+ RETURN
+END IF
-ELSE
- IF (p .EQ. 0_I4B) THEN
- DO jj = 1, q + 1
- cnt = cnt + 1
- temp(1:2, jj) = [xi(1, jj), eta(1, jj)]
- END DO
- END IF
+ij(1, 1) = 1
+ij(2, 1) = 1
- IF (q .EQ. 0_I4B) THEN
- DO ii = 1, p + 1
- cnt = cnt + 1
- temp(1:2, ii) = [xi(ii, 1), eta(ii, 1)]
- END DO
- END IF
+ij(1, 2) = p + 1
+ij(2, 2) = 1
-END IF
+ij(1, 3) = p + 1
+ij(2, 3) = q + 1
-IF (ALL([p, q] .GE. 1_I4B)) THEN
- DO iedge = 1, tEdges
- p1 = edgeConnectivity(1, iedge)
- p2 = edgeConnectivity(2, iedge)
+ij(1, 4) = 1
+ij(2, 4) = q + 1
- IF (ij(1, p1) .EQ. ij(1, p2)) THEN
- ii1 = ij(1, p1)
- ii2 = ii1
- dii = 1
- ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN
- ii1 = ij(1, p1) + 1
- ii2 = ij(1, p2) - 1
- dii = 1
- ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN
- ii1 = ij(1, p1) - 1
- ii2 = ij(1, p2) + 1
- dii = -1
- END IF
+isok = (p .GE. 1) .AND. (q .GE. 1)
- IF (ij(2, p1) .EQ. ij(2, p2)) THEN
- jj1 = ij(2, p1)
- jj2 = jj1
- djj = 1
- ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN
- jj1 = ij(2, p1) + 1
- jj2 = ij(2, p2) - 1
- djj = 1
- ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN
- jj1 = ij(2, p1) - 1
- jj2 = ij(2, p2) + 1
- djj = -1
- END IF
+IF (isok) THEN
+
+ DO ii = 1, 4
+ cnt = cnt + 1
+ jj = pointsOrder(ii)
+ temp(1, ii) = xi(ij(1, jj), ij(2, jj))
+
+ temp(2, ii) = eta(ij(1, jj), ij(2, jj))
- DO ii = ii1, ii2, dii
- DO jj = jj1, jj2, djj
- cnt = cnt + 1
- temp(:, cnt) = [xi(ii, jj), eta(ii, jj)]
- END DO
- END DO
END DO
- ! internal nodes
- IF (ALL([p, q] .GE. 2_I4B)) THEN
+END IF
- CALL Reallocate( &
- & xi_in, &
- & MAX(p - 1, 1_I4B), &
- & MAX(q - 1_I4B, 1_I4B))
- CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2))
- CALL Reallocate(temp_in, 2, SIZE(xi_in))
+abool = (p .EQ. 1) .AND. (q .EQ. 1)
+IF (abool) RETURN
+
+isok = (p .GE. 1) .AND. (q .GE. 1)
+IF (.NOT. isok) RETURN
+
+DO iedge = 1, tEdges
+ p1 = edgeConnectivity(1, iedge)
+ p2 = edgeConnectivity(2, iedge)
+
+ IF (ij(1, p1) .EQ. ij(1, p2)) THEN
+ ii1 = ij(1, p1)
+ ii2 = ii1
+ dii = 1
+ ELSE IF (ij(1, p1) .LT. ij(1, p2)) THEN
+ ii1 = ij(1, p1) + 1
+ ii2 = ij(1, p2) - 1
+ dii = 1
+ ELSE IF (ij(1, p1) .GT. ij(1, p2)) THEN
+ ii1 = ij(1, p1) - 1
+ ii2 = ij(1, p2) + 1
+ dii = -1
+ END IF
- IF (p .LE. 1_I4B) THEN
- ii1 = 1
- ii2 = 1
- ELSE
- ii1 = 2
- ii2 = p
- END IF
+ IF (ij(2, p1) .EQ. ij(2, p2)) THEN
+ jj1 = ij(2, p1)
+ jj2 = jj1
+ djj = 1
+ ELSE IF (ij(2, p1) .LT. ij(2, p2)) THEN
+ jj1 = ij(2, p1) + 1
+ jj2 = ij(2, p2) - 1
+ djj = 1
+ ELSE IF (ij(2, p1) .GT. ij(2, p2)) THEN
+ jj1 = ij(2, p1) - 1
+ jj2 = ij(2, p2) + 1
+ djj = -1
+ END IF
- IF (q .LE. 1_I4B) THEN
- jj1 = 1
- jj2 = 1
- ELSE
- jj1 = 2
- jj2 = q
- END IF
+ DO ii = ii1, ii2, dii
+ DO jj = jj1, jj2, djj
+ cnt = cnt + 1
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ END DO
+ END DO
+END DO
- xi_in = xi(ii1:ii2, jj1:jj2)
- eta_in = eta(ii1:ii2, jj1:jj2)
+! internal nodes
+isok = (p .GE. 2) .AND. (q .GE. 2)
+IF (.NOT. isok) RETURN
- CALL IJ2VEFC_Quadrangle_Clockwise( &
- & xi=xi_in, &
- & eta=eta_in, &
- & temp=temp_in, &
- & p=MAX(p - 2, 0_I4B), &
- & q=MAX(q - 2, 0_I4B), &
- & startNode=startNode)
+CALL Reallocate(xi_in, MAX(p - 1, 1_I4B), MAX(q - 1_I4B, 1_I4B))
+CALL Reallocate(eta_in, SIZE(xi_in, 1), SIZE(xi_in, 2))
+CALL Reallocate(temp_in, 2, SIZE(xi_in))
- ii1 = cnt + 1
- ii2 = ii1 + SIZE(temp_in, 2) - 1
- temp(1:2, ii1:ii2) = temp_in
- END IF
+IF (p .LE. 1_I4B) THEN
+ ii1 = 1
+ ii2 = 1
+ELSE
+ ii1 = 2
+ ii2 = p
+END IF
+IF (q .LE. 1_I4B) THEN
+ jj1 = 1
+ jj2 = 1
+ELSE
+ jj1 = 2
+ jj2 = q
END IF
+xi_in = xi(ii1:ii2, jj1:jj2)
+eta_in = eta(ii1:ii2, jj1:jj2)
+
+CALL IJ2VEFC_Quadrangle_Clockwise(xi=xi_in, &
+ eta=eta_in, &
+ temp=temp_in, &
+ p=MAX(p - 2, 0_I4B), &
+ q=MAX(q - 2, 0_I4B), &
+ startNode=startNode)
+
+ii1 = cnt + 1
+ii2 = ii1 + SIZE(temp_in, 2) - 1
+temp(1:2, ii1:ii2) = temp_in
+
IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in)
IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in)
IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in)
@@ -553,56 +527,35 @@
MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise
! internal variables
-INTEGER(I4B) :: cnt, m, ii, jj, kk, ll, N, ij(2, 4), iedge, p1, p2
+INTEGER(I4B) :: cnt, ii, jj, ll, N, ij(2, 4), iedge, p1, p2
INTEGER(I4B), PARAMETER :: tEdges = 4
INTEGER(I4B) :: edgeConnectivity(2, 4), ii1, ii2, dii, jj1, jj2, djj, &
-& pointsOrder(4)
-REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), &
- & temp_in(:, :)
+ pointsOrder(4)
+REAL(DFP), ALLOCATABLE :: xi_in(:, :), eta_in(:, :), &
+ temp_in(:, :)
+LOGICAL(LGT) :: isok, abool
! vertices
N = (p + 1) * (q + 1)
cnt = 0
ll = -1
-SELECT CASE (startNode)
-CASE (1)
- edgeConnectivity(:, 1) = [1, 2]
- edgeConnectivity(:, 2) = [2, 3]
- edgeConnectivity(:, 3) = [3, 4]
- edgeConnectivity(:, 4) = [4, 1]
- pointsOrder = [1, 2, 3, 4]
-CASE (2)
- edgeConnectivity(:, 1) = [2, 3]
- edgeConnectivity(:, 2) = [3, 4]
- edgeConnectivity(:, 3) = [4, 1]
- edgeConnectivity(:, 4) = [1, 2]
- pointsOrder = [2, 3, 4, 1]
-CASE (3)
- edgeConnectivity(:, 1) = [3, 4]
- edgeConnectivity(:, 2) = [4, 1]
- edgeConnectivity(:, 3) = [1, 2]
- edgeConnectivity(:, 4) = [2, 3]
- pointsOrder = [3, 4, 1, 2]
-CASE (4)
- edgeConnectivity(:, 1) = [4, 1]
- edgeConnectivity(:, 2) = [1, 2]
- edgeConnectivity(:, 3) = [2, 3]
- edgeConnectivity(:, 4) = [3, 4]
- pointsOrder = [4, 1, 2, 3]
-END SELECT
+CALL GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, startNode)
-IF (ALL([p, q] .EQ. 0_I4B)) THEN
- temp(:, 1) = [xi(1, 1), eta(1, 1)]
+isok = (p .EQ. 0) .AND. (q .EQ. 0)
+IF (isok) THEN
+ temp(1, 1) = xi(1, 1)
+ temp(2, 1) = eta(1, 1)
RETURN
END IF
-ij(:, 1) = [1, 1]
-ij(:, 2) = [p + 1, 1]
-ij(:, 3) = [p + 1, q + 1]
-ij(:, 4) = [1, q + 1]
+ij(1:2, 1) = [1, 1]
+ij(1:2, 2) = [p + 1, 1]
+ij(1:2, 3) = [p + 1, q + 1]
+ij(1:2, 4) = [1, q + 1]
-IF (ALL([p, q] .GE. 1_I4B)) THEN
+isok = (p .GE. 1) .AND. (q .GE. 1)
+IF (isok) THEN
DO ii = 1, 4
cnt = cnt + 1
jj = pointsOrder(ii)
@@ -611,9 +564,12 @@
& eta(ij(1, jj), ij(2, jj)) &
& ]
END DO
- IF (ALL([p, q] .EQ. 1_I4B)) RETURN
+
+ abool = (p .EQ. 1) .AND. (q .EQ. 1)
+ IF (abool) RETURN
ELSE
+
DO ii = 1, MIN(p, 1) + 1
DO jj = 1, MIN(q, 1) + 1
cnt = cnt + 1
@@ -717,191 +673,243 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE InterpolationPoint_Quadrangle1
-ans = InterpolationPoint_Quadrangle2( &
- & p=order, &
- & q=order, &
- & ipType1=ipType, &
- & ipType2=ipType, &
- & xij=xij, &
- & layout=layout, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda &
- & )
+ans = InterpolationPoint_Quadrangle2(p=order, q=order, ipType1=ipType, &
+ ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda)
END PROCEDURE InterpolationPoint_Quadrangle1
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Quadrangle1_
+CALL InterpolationPoint_Quadrangle2_(p=order, q=order, ipType1=ipType, &
+ ipType2=ipType, xij=xij, layout=layout, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE InterpolationPoint_Quadrangle1_
+
!----------------------------------------------------------------------------
! InterpolationPoint_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE InterpolationPoint_Quadrangle2
-! internal variables
-REAL(DFP) :: x(p + 1), y(q + 1), &
- & xi(p + 1, q + 1), eta(p + 1, q + 1)
-REAL(DFP), ALLOCATABLE :: temp(:, :)
-INTEGER(I4B) :: ii, jj, kk, nsd
-
-x = InterpolationPoint_Line( &
- & order=p, &
- & ipType=ipType1, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-y = InterpolationPoint_Line( &
- & order=q, &
- & ipType=ipType2, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
+INTEGER(I4B) :: nrow, ncol
+
+nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1)
+ncol = (p + 1) * (q + 1)
+ALLOCATE (ans(nrow, ncol))
+
+CALL InterpolationPoint_Quadrangle2_(p=p, q=q, ipType1=ipType1, &
+ ipType2=ipType2, ans=ans, nrow=nrow, ncol=ncol, layout=layout, xij=xij, &
+ alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, &
+ beta2=beta2, lambda2=lambda2)
+
+END PROCEDURE InterpolationPoint_Quadrangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Quadrangle2_
+REAL(DFP), PARAMETER :: biunit_xij(2) = [-1.0_DFP, 1.0_DFP]
+
+REAL(DFP) :: x(p + 1), y(q + 1), xi(p + 1, q + 1), eta(p + 1, q + 1)
+INTEGER(I4B) :: ii, jj, kk, tsize
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
+ nrow = SIZE(xij, 1)
ELSE
- nsd = 2
+ nrow = 2
END IF
-CALL Reallocate(ans, nsd, (p + 1) * (q + 1))
-CALL Reallocate(temp, 2, (p + 1) * (q + 1))
+ncol = (p + 1) * (q + 1)
-xi = 0.0_DFP
-eta = 0.0_DFP
+CALL InterpolationPoint_Line_(order=p, ipType=ipType1, xij=biunit_xij, &
+ layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, &
+ ans=x, tsize=tsize)
+CALL InterpolationPoint_Line_(order=q, ipType=ipType2, xij=biunit_xij, &
+ layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, &
+ ans=y, tsize=tsize)
+
+kk = 0
DO ii = 1, p + 1
DO jj = 1, q + 1
+ kk = kk + 1
xi(ii, jj) = x(ii)
+ ans(1, kk) = x(ii)
+
eta(ii, jj) = y(jj)
+ ans(2, kk) = y(jj)
END DO
END DO
-IF (layout .EQ. "VEFC") THEN
- CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=temp, p=p, q=q)
-ELSE
- kk = 0
- DO ii = 1, p + 1
- DO jj = 1, q + 1
- kk = kk + 1
- temp(1, kk) = xi(ii, jj)
- temp(2, kk) = eta(ii, jj)
- END DO
- END DO
+IF (layout(1:4) .EQ. "VEFC") THEN
+ CALL IJ2VEFC_Quadrangle(xi=xi, eta=eta, temp=ans(1:2, 1:ncol), p=p, q=q)
END IF
IF (PRESENT(xij)) THEN
- ans = FromBiUnitQuadrangle2Quadrangle(xin=temp, x1=xij(:, 1), &
- & x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4))
-ELSE
- ans = temp
+ CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, 1:ncol), &
+ x1=xij(:, 1), x2=xij(:, 2), &
+ x3=xij(:, 3), x4=xij(:, 4), &
+ ans=ans, nrow=ii, ncol=jj)
END IF
-END PROCEDURE InterpolationPoint_Quadrangle2
+
+END PROCEDURE InterpolationPoint_Quadrangle2_
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Quadrangle1
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Quadrangle1_(order=order, i=i, xij=xij, ans=ans, &
+ tsize=tsize)
+END PROCEDURE LagrangeCoeff_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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)
+INTEGER(I4B) :: info, nrow, ncol
+
+tsize = SIZE(xij, 2)
+
+ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+! V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle)
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Quadrangle, &
+ ans=V, nrow=nrow, ncol=ncol)
CALL GetLU(A=V, IPIV=ipiv, info=info)
-CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Quadrangle1
+CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Quadrangle1_
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Quadrangle2
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Quadrangle2_(order=order, i=i, v=v, isVandermonde=.TRUE., &
+ ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff_Quadrangle2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
+
+tsize = SIZE(v, 1)
+
+vtemp = v; ans(1:tsize) = 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
+CALL LUSolve(A=vtemp, B=ans(1:tsize), 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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Quadrangle3_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Quadrangle3
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Quadrangle3_
+INTEGER(I4B) :: info
+tsize = SIZE(v, 1)
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Quadrangle3_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Quadrangle4
-INTEGER(I4B) :: basisType0, ii, jj, indx
-REAL(DFP) :: ans1(SIZE(xij, 2), 0:order)
-REAL(DFP) :: ans2(SIZE(xij, 2), 0:order)
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff_Quadrangle4_(order=order, xij=xij, basisType=basisType, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeCoeff_Quadrangle4
-basisType0 = input(default=Monomial, option=basisType)
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Quadrangle4_
+INTEGER(I4B) :: basisType0
+
+basisType0 = Input(default=Monomial, option=basisType)
IF (basisType0 .EQ. Heirarchical) THEN
- ans = HeirarchicalBasis_Quadrangle2(p=order, q=order, xij=xij)
-ELSE
- ans = TensorProdBasis_Quadrangle1( &
- & p=order, &
- & q=order, &
- & xij=xij, &
- & basisType1=basisType0, &
- & basisType2=basisType0, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda)
+ CALL HeirarchicalBasis_Quadrangle2_(p=order, q=order, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
+ CALL GetInvMat(ans(1:nrow, 1:ncol))
+ RETURN
END IF
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Quadrangle4
+! ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=order, q=order, &
+CALL TensorProdBasis_Quadrangle1_(p=order, q=order, &
+ xij=xij, basisType1=basisType0, basisType2=basisType0, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, &
+ beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+
+END PROCEDURE LagrangeCoeff_Quadrangle4_
!----------------------------------------------------------------------------
! LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Quadrangle5
-INTEGER(I4B) :: ii, jj, kk, indx, basisType(2)
-REAL(DFP) :: ans1(SIZE(xij, 2), 0:p)
-REAL(DFP) :: ans2(SIZE(xij, 2), 0:q)
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeCoeff_Quadrangle5_(p=p, q=q, xij=xij, basisType1=basisType1, &
+ basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, &
+ alpha2=alpha2, beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeCoeff_Quadrangle5
-basisType(1) = input(default=Monomial, option=basisType1)
-basisType(2) = input(default=Monomial, option=basisType2)
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Quadrangle5_
+INTEGER(I4B) :: jj, kk, basisType(2)
+
+basisType(1) = Input(default=Monomial, option=basisType1)
+basisType(2) = Input(default=Monomial, option=basisType2)
IF (ALL(basisType .EQ. Heirarchical)) THEN
- ans = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij)
-ELSE
- ans = TensorProdBasis_Quadrangle1( &
- & p=p, &
- & q=q, &
- & xij=xij, &
- & basisType1=basisType(1), &
- & basisType2=basisType(2), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2)
+ ! ans(1:nrow, 1:ncol) = HeirarchicalBasis_Quadrangle2(p=p, q=q, xij=xij)
+ CALL HeirarchicalBasis_Quadrangle2_(p=p, q=q, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+ CALL GetInvMat(ans(1:nrow, 1:ncol))
+ RETURN
END IF
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Quadrangle5
+! ans(1:nrow, 1:ncol) = TensorProdBasis_Quadrangle1(p=p, q=q, xij=xij, &
+CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, &
+ basisType1=basisType(1), alpha1=alpha1, beta1=beta1, lambda1=lambda1, &
+ basisType2=basisType(2), alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+
+END PROCEDURE LagrangeCoeff_Quadrangle5_
!----------------------------------------------------------------------------
!
@@ -918,36 +926,57 @@
!----------------------------------------------------------------------------
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
+#define TP size(xij, 2)
+
+REAL(DFP) :: P1(TP, order + 1), P2(TP, order + 1), temp(TP, 3)
+
+REAL(DFP) :: alpha, beta
+
+INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii
+
+#undef TP
-x = xij(1, :)
-y = xij(2, :)
nrow = SIZE(xij, 2)
ncol = (order + 1) * (order + 2) / 2
-P1 = LegendreEvalAll(n=order, x=x)
+CALL LegendreEvalAll_(n=order, x=xij(1, :), ans=P1, nrow=indx(1), &
+ ncol=indx(2))
! we do not need x now, so let store (1-y)/2 in x
-x = 0.5_DFP * (1.0_DFP - y)
+DO CONCURRENT(ii=1:nrow)
+ temp(ii, 3) = xij(2, ii)
+ temp(ii, 1) = 0.5_DFP * (1.0_DFP - temp(ii, 3))
+END DO
+
alpha = 0.0_DFP
beta = 0.0_DFP
cnt = 0
+! temp1 = 0.5 * (1.0 - y)
+! temp3 = y
+
DO k1 = 0, order
- avec = (x)**k1 ! note here x = 0.5_DFP*(1-y)
+ !! note here temp1 is
+ !! note here x = 0.5_DFP*(1-y)
+ DO CONCURRENT(ii=1:nrow)
+ temp(ii, 2) = temp(ii, 1)**k1
+ END DO
+
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)
+ ! P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta)
+ CALL JacobiEvalAll_(n=max_k2, x=temp(:, 3), alpha=alpha, beta=beta, ans=P2, &
+ nrow=indx(1), ncol=indx(2))
DO k2 = 0, max_k2
cnt = cnt + 1
- ans(:, cnt) = P1(:, k1 + 1) * avec * P2(:, k2 + 1)
+
+ DO CONCURRENT(ii=1:nrow)
+ ans(ii, cnt) = P1(ii, k1 + 1) * temp(ii, 2) * P2(ii, k2 + 1)
+ END DO
END DO
END DO
@@ -971,8 +1000,8 @@
MODULE PROCEDURE DubinerGradient_Quadrangle1_
REAL(DFP), DIMENSION(SIZE(xij, 2), order + 1) :: P1, P2, dP1, dP2
REAL(DFP), DIMENSION(SIZE(xij, 2)) :: avec, bvec, x, y
-REAL(DFP) :: alpha, beta
-INTEGER(I4B) :: k1, k2, max_k2, cnt
+REAL(DFP) :: alpha, beta, areal
+INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii
tsize1 = SIZE(xij, 2)
tsize2 = (order + 1) * (order + 2) / 2
@@ -980,8 +1009,13 @@
x = xij(1, :)
y = xij(2, :)
-P1 = LegendreEvalAll(n=order, x=x)
-dP1 = LegendreGradientEvalAll(n=order, x=x)
+
+! P1 = LegendreEvalAll(n=order, x=x)
+CALL LegendreEvalAll_(n=order, x=x, ans=P1, nrow=indx(1), ncol=indx(2))
+
+! dP1 = LegendreGradientEvalAll(n=order, x=x)
+CALL LegendreGradientEvalAll_(n=order, x=x, ans=dP1, nrow=indx(1), &
+ ncol=indx(2))
! we do not need x now, so let store (1-y)/2 in x
x = 0.5_DFP * (1.0_DFP - y)
@@ -996,24 +1030,25 @@
max_k2 = order - k1
- P2(:, 1:max_k2 + 1) = JacobiEvalAll( &
- & n=max_k2, &
- & x=y, &
- & alpha=alpha, &
- & beta=beta)
+ CALL JacobiEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, &
+ ans=P2, nrow=indx(1), ncol=indx(2))
- dP2(:, 1:max_k2 + 1) = JacobiGradientEvalAll( &
- & n=max_k2, &
- & x=y, &
- & alpha=alpha, &
- & beta=beta)
+ CALL JacobiGradientEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, &
+ ans=dP2, nrow=indx(1), ncol=indx(2))
+
+ areal = REAL(k1, DFP)
DO k2 = 0, max_k2
cnt = cnt + 1
- ans(:, cnt, 1) = dP1(:, k1 + 1) * avec * P2(:, k2 + 1)
- ans(:, cnt, 2) = P1(:, k1 + 1) * bvec * &
- & (x * dP2(:, k2 + 1) - 0.5_DFP * REAL(k1, DFP) * P2(:, k2 + 1))
+
+ DO CONCURRENT(ii=1:tsize1)
+ ans(ii, cnt, 1) = dP1(ii, k1 + 1) * avec(ii) * P2(ii, k2 + 1)
+ ans(ii, cnt, 2) = P1(ii, k1 + 1) * bvec(ii) * &
+ (x(ii) * dP2(ii, k2 + 1) - 0.5_DFP * areal * P2(ii, k2 + 1))
+ END DO
+
END DO
+
END DO
END PROCEDURE DubinerGradient_Quadrangle1_
@@ -1053,551 +1088,890 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorProdBasis_Quadrangle1
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2))
+INTEGER(I4B) :: nrow, ncol
+CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol, basisType1=basisType1, basisType2=basisType2, &
+ alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, &
+ beta2=beta2, lambda2=lambda2)
+END PROCEDURE TensorProdBasis_Quadrangle1
+
+!----------------------------------------------------------------------------
+! TensorProdBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasis_Quadrangle1_
REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1)
-INTEGER(I4B) :: ii, k1, k2, cnt
+INTEGER(I4B) :: k1, k2, ii
-x = xij(1, :)
-y = xij(2, :)
+nrow = SIZE(xij, 2)
+ncol = (p + 1) * (q + 1)
-P1 = BasisEvalAll_Line( &
- & order=p, &
- & x=x, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-Q1 = BasisEvalAll_Line( &
- & order=q, &
- & x=y, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
+CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, &
+ nrow=k1, ncol=k2)
-cnt = 0
+CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, &
+ nrow=k1, ncol=k2)
-DO k2 = 1, q + 1
- DO k1 = 1, p + 1
- cnt = cnt + 1
- ans(:, cnt) = P1(:, k1) * Q1(:, k2)
- END DO
+DO CONCURRENT(k1=1:p + 1, k2=1:q + 1, ii=1:nrow)
+ ans(ii, (k2 - 1) * (p + 1) + k1) = P1(ii, k1) * Q1(ii, k2)
END DO
-END PROCEDURE TensorProdBasis_Quadrangle1
+END PROCEDURE TensorProdBasis_Quadrangle1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorProdBasis_Quadrangle2
+INTEGER(I4B) :: nrow, ncol
+CALL TensorProdBasis_Quadrangle2_(p=p, q=q, x=x, y=y, ans=ans, nrow=nrow, &
+ ncol=ncol, basisType1=basisType1, basisType2=basisType2, &
+ alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, &
+ beta2=beta2, lambda2=lambda2)
+END PROCEDURE TensorProdBasis_Quadrangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasis_Quadrangle2_
REAL(DFP) :: xij(2, SIZE(x) * SIZE(y))
-INTEGER(I4B) :: ii, jj, cnt
+INTEGER(I4B) :: ii, jj
-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
+nrow = SIZE(x)
+ncol = SIZE(y)
+
+DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ xij(1, ncol * (ii - 1) + jj) = x(ii)
+ xij(2, ncol * (ii - 1) + jj) = y(jj)
END DO
-ans = TensorProdBasis_Quadrangle1( &
- & p=p, &
- & q=q, &
- & xij=xij, &
- & basisType1=basisType1, &
- & basisType2=basisType2, &
- & alpha1=alpha1, &
- & alpha2=alpha2, &
- & beta1=beta1, &
- & beta2=beta2, &
- & lambda1=lambda1, &
- & lambda2=lambda2)
+CALL TensorProdBasis_Quadrangle1_(p=p, q=q, xij=xij, basisType1=basisType1, &
+ basisType2=basisType2, alpha1=alpha1, alpha2=alpha2, beta1=beta1, &
+ beta2=beta2, lambda1=lambda1, lambda2=lambda2, &
+ ans=ans, nrow=nrow, ncol=ncol)
-END PROCEDURE TensorProdBasis_Quadrangle2
+END PROCEDURE TensorProdBasis_Quadrangle2_
!----------------------------------------------------------------------------
! VertexBasis_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE VertexBasis_Quadrangle1
-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)
+INTEGER(I4B) :: nrow, ncol
+CALL VertexBasis_Quadrangle1_(x=x, y=y, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE VertexBasis_Quadrangle1
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle2
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VertexBasis_Quadrangle1_
+nrow = SIZE(x)
+ncol = 4
+ans(1:nrow, 1) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP - y)
+ans(1:nrow, 2) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP - y)
+ans(1:nrow, 3) = 0.25_DFP * (1.0_DFP + x) * (1.0_DFP + y)
+ans(1:nrow, 4) = 0.25_DFP * (1.0_DFP - x) * (1.0_DFP + y)
+END PROCEDURE VertexBasis_Quadrangle1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE VertexBasis_Quadrangle3_(L1, L2, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ !! L1 Lobatto polynomial evaluated at x coordinates
+ !! L2 is Lobatto polynomial evaluated at y coordinates
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(L1, 1), 4)
+ !! ans(:,v1) basis function of vertex v1 at all points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! internal variable
+ INTEGER(I4B) :: ii
+
+ nrow = SIZE(L1, 1)
+ ncol = 4
+
+ DO CONCURRENT(ii=1:nrow)
+ ans(ii, 1) = L1(ii, 0) * L2(ii, 0)
+ ans(ii, 2) = L1(ii, 1) * L2(ii, 0)
+ ans(ii, 3) = L1(ii, 1) * L2(ii, 1)
+ ans(ii, 4) = L1(ii, 0) * L2(ii, 1)
+ END DO
+
+END SUBROUTINE VertexBasis_Quadrangle3_
+
+!----------------------------------------------------------------------------
+! VertexBasis_Quadrangle
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: nrow, ncol
+CALL VertexBasis_Quadrangle2_(xij=xij, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE VertexBasis_Quadrangle2
!----------------------------------------------------------------------------
-! VertexBasisGradient_Quadrangle2
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE VertexBasisGradient_Quadrangle2
-ans(:, 1, 1) = dL1(:, 0) * L2(:, 0)
-ans(:, 2, 1) = dL1(:, 1) * L2(:, 0)
-ans(:, 3, 1) = dL1(:, 1) * L2(:, 1)
-ans(:, 4, 1) = dL1(:, 0) * L2(:, 1)
-ans(:, 1, 2) = L1(:, 0) * dL2(:, 0)
-ans(:, 2, 2) = L1(:, 1) * dL2(:, 0)
-ans(:, 3, 2) = L1(:, 1) * dL2(:, 1)
-ans(:, 4, 2) = L1(:, 0) * dL2(:, 1)
-END PROCEDURE VertexBasisGradient_Quadrangle2
+MODULE PROCEDURE VertexBasis_Quadrangle2_
+CALL VertexBasis_Quadrangle1_(x=xij(1, :), y=xij(2, :), ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE VertexBasis_Quadrangle2_
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle
+! VertexBasisGradient_Quadrangle2_
!----------------------------------------------------------------------------
-MODULE PROCEDURE VertexBasis_Quadrangle3
-ans = VertexBasis_Quadrangle1( &
- & x=xij(1, :), &
- & y=xij(2, :))
-END PROCEDURE VertexBasis_Quadrangle3
+PURE SUBROUTINE VertexBasisGradient_Quadrangle2_(L1, L2, dL1, dL2, &
+ ans, dim1, dim2, dim3)
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:)
+ !! L1 Lobatto polynomial evaluated at x coordinates
+ REAL(DFP), INTENT(IN) :: L2(1:, 0:)
+ !! L2 is Lobatto polynomial evaluated at y coordinates
+ REAL(DFP), INTENT(IN) :: dL1(1:, 0:)
+ !! L1 Lobatto polynomial evaluated at x coordinates
+ REAL(DFP), INTENT(IN) :: dL2(1:, 0:)
+ !! L2 is Lobatto polynomial evaluated at y coordinates
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1= SIZE(L1, 1)
+ !! dim2= 4
+ !! dim3 = 2
+ !! Gradient of vertex basis
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ dim1 = SIZE(L1, 1)
+ dim2 = 4
+ dim3 = 2
+ ans(1:dim1, 1, 1) = dL1(1:dim1, 0) * L2(1:dim1, 0)
+ ans(1:dim1, 2, 1) = dL1(1:dim1, 1) * L2(1:dim1, 0)
+ ans(1:dim1, 3, 1) = dL1(1:dim1, 1) * L2(1:dim1, 1)
+ ans(1:dim1, 4, 1) = dL1(1:dim1, 0) * L2(1:dim1, 1)
+ ans(1:dim1, 1, 2) = L1(1:dim1, 0) * dL2(1:dim1, 0)
+ ans(1:dim1, 2, 2) = L1(1:dim1, 1) * dL2(1:dim1, 0)
+ ans(1:dim1, 3, 2) = L1(1:dim1, 1) * dL2(1:dim1, 1)
+ ans(1:dim1, 4, 2) = L1(1:dim1, 0) * dL2(1:dim1, 1)
+
+END SUBROUTINE VertexBasisGradient_Quadrangle2_
!----------------------------------------------------------------------------
! VerticalEdgeBasis_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE VerticalEdgeBasis_Quadrangle
-REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2))
-INTEGER(I4B) :: maxQ, k2, cnt
+INTEGER(I4B) :: nrow, ncol
+CALL VerticalEdgeBasis_Quadrangle_(qe1=qe1, qe2=qe2, x=x, y=y, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE VerticalEdgeBasis_Quadrangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VerticalEdgeBasis_Quadrangle_
+! REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2))
+INTEGER(I4B) :: maxQ, aint, bint
+INTEGER(I4B), PARAMETER :: maxP = 1, orient = 1
+REAL(DFP), ALLOCATABLE :: L2(:, :), L1(:, :)
maxQ = MAX(qe1, qe2)
-L2 = LobattoEvalAll(n=maxQ, x=y)
+aint = SIZE(y)
+nrow = SIZE(x)
+ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ))
-cnt = 0
+CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint)
+CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint)
-DO k2 = 2, qe1
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP - x) * L2(:, k2)
-END DO
+CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, ans=ans, &
+ nrow=nrow, ncol=ncol, qe1Orient=orient, qe2Orient=orient)
-DO k2 = 2, qe2
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP + x) * L2(:, k2)
-END DO
+DEALLOCATE (L2, L1)
-END PROCEDURE VerticalEdgeBasis_Quadrangle
+END PROCEDURE VerticalEdgeBasis_Quadrangle_
!----------------------------------------------------------------------------
-! VerticalEdgeBasis_Quadrangle2
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2
-INTEGER(I4B) :: k2, cnt
+PURE SUBROUTINE VerticalEdgeBasis_Quadrangle2_(qe1, qe2, L1, L2, &
+ ans, nrow, ncol, qe1Orient, qe2Orient)
+ INTEGER(I4B), INTENT(IN) :: qe1
+ !! order on left vertical edge (e1), it should be greater than 1
+ INTEGER(I4B), INTENT(IN) :: qe2
+ !! order on right vertical edge(e2), it should be greater than 1
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ !! Lobatto polynomials in x and y direction.
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(L1, 1), qe1 + qe2 - 2)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written to ans
+ INTEGER(I4B), INTENT(IN), OPTIONAL :: qe1Orient, qe2Orient
+ !! orientation fo left and write vertical edge
+ !! it can be 1 or -1
+
+ INTEGER(I4B) :: k2, cnt, ii
+ REAL(DFP) :: o1, o2
+
+ o1 = REAL(-qe1Orient, kind=DFP)
+ ! NOTE: Here we multiply by -1 because the left edge is oriented downwards &
+ ! in master element
+ o2 = REAL(qe2Orient, kind=DFP)
+
+ nrow = SIZE(L1, 1)
+ ncol = qe1 + qe2 - 2
+ cnt = qe1 - 1
+
+ !! left vertical
+ DO CONCURRENT(k2=2:qe1, ii=1:nrow)
+ ans(ii, k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2)
+ END DO
-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
+ !! right vertical
+ DO CONCURRENT(k2=2:qe2, ii=1:nrow)
+ ans(ii, cnt + k2 - 1) = (o2**k2) * L1(ii, 1) * L2(ii, k2)
+ END DO
-END PROCEDURE VerticalEdgeBasis_Quadrangle2
+END SUBROUTINE VerticalEdgeBasis_Quadrangle2_
!----------------------------------------------------------------------------
! VerticalEdgeBasisGradient_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE VerticalEdgeBasisGradient_Quadrangle2
-INTEGER(I4B) :: k2, cnt
-cnt = 0
-DO k2 = 2, qe1
- cnt = cnt + 1
- ans(:, cnt, 1) = dL1(:, 0) * L2(:, k2)
- ans(:, cnt, 2) = L1(:, 0) * dL2(:, k2)
-END DO
-DO k2 = 2, qe2
- cnt = cnt + 1
- ans(:, cnt, 1) = dL1(:, 1) * L2(:, k2)
- ans(:, cnt, 2) = L1(:, 1) * dL2(:, k2)
-END DO
-END PROCEDURE VerticalEdgeBasisGradient_Quadrangle2
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Returns the vertex basis functions on biunit quadrangle
+
+PURE SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_(qe1, qe2, &
+ L1, L2, dL1, dL2, ans, dim1, dim2, dim3, qe1Orient, qe2Orient)
+ INTEGER(I4B), INTENT(IN) :: qe1
+ !! order on left vertical edge (e1), it should be greater than 1
+ INTEGER(I4B), INTENT(IN) :: qe2
+ !! order on right vertical edge(e2), it should be greater than 1
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ !! Lobatto polynomials in x and y direction.
+ REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
+ !! Lobatto polynomials in x and y direction.
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1=SIZE(L1, 1)
+ !! dim2=qe1 + qe2 - 2
+ !! dim3= 2
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! range of data written to ans
+ INTEGER(I4B), INTENT(IN) :: qe1Orient, qe2Orient
+ !! orientation fo left and write vertical edge
+ !! it can be 1 or -1
+
+ INTEGER(I4B) :: k2, cnt, ii
+ REAL(DFP) :: o1, o2
+
+ o1 = REAL(-qe1Orient, kind=DFP)
+ ! NOTE: Here we multiply by -1 because the left edge is oriented downwards &
+ ! in master element
+ o2 = REAL(qe2Orient, kind=DFP)
+
+ dim1 = SIZE(L1, 1)
+ dim2 = qe1 + qe2 - 2
+ dim3 = 2
+
+ cnt = qe1 - 1
+
+ DO CONCURRENT(k2=2:qe1, ii=1:dim1)
+ ans(ii, k2 - 1, 1) = (o1**(k2 - 1)) * dL1(ii, 0) * L2(ii, k2)
+ ans(ii, k2 - 1, 2) = (o1**(k2 - 1)) * L1(ii, 0) * dL2(ii, k2)
+ END DO
+
+ DO CONCURRENT(k2=2:qe2, ii=1:dim1)
+ ans(ii, cnt + k2 - 1, 1) = (o2**(k2 - 1)) * dL1(ii, 1) * L2(ii, k2)
+ ans(ii, cnt + k2 - 1, 2) = (o2**(k2 - 1)) * L1(ii, 1) * dL2(ii, k2)
+ END DO
+
+END SUBROUTINE VerticalEdgeBasisGradient_Quadrangle2_
!----------------------------------------------------------------------------
! HorizontalEdgeBasis_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle
-REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4))
-INTEGER(I4B) :: maxP, k1, cnt
+INTEGER(I4B) :: nrow, ncol
+CALL HorizontalEdgeBasis_Quadrangle_(pe3, pe4, x, y, ans, nrow, ncol)
+END PROCEDURE HorizontalEdgeBasis_Quadrangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle_
+INTEGER(I4B) :: maxP, aint, bint
+INTEGER(I4B), PARAMETER :: maxQ = 1, orient = 1
+
+REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :)
maxP = MAX(pe3, pe4)
-L1 = LobattoEvalAll(n=maxP, x=x)
+nrow = SIZE(x)
+aint = SIZE(y)
-cnt = 0
+ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ))
-DO k1 = 2, pe3
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP - y) * L1(:, k1)
-END DO
+CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint)
+CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint)
-DO k1 = 2, pe4
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP + y) * L1(:, k1)
-END DO
+CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, &
+ ans=ans, nrow=nrow, ncol=ncol, pe3Orient=orient, pe4Orient=orient)
-END PROCEDURE HorizontalEdgeBasis_Quadrangle
+DEALLOCATE (L1, L2)
+
+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
+PURE SUBROUTINE HorizontalEdgeBasis_Quadrangle2_(pe3, pe4, L1, L2, &
+ ans, nrow, ncol, pe3Orient, pe4Orient)
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on bottom vertical edge (e3), it should be greater than 1
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order on top vertical edge(e4), it should be greater than 1
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(L1, 1), pe3 + pe4 - 2)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and columns written to ans
+ INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient
+ !! orientaion of bottom and top edge
+
+ INTEGER(I4B) :: k1, cnt, ii
+ REAL(DFP) :: o1, o2
+
+ o1 = REAL(pe3Orient, kind=DFP)
+
+ o2 = REAL(-pe4Orient, kind=DFP)
+ ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards &
+ ! in master element
+
+ nrow = SIZE(L1, 1)
+ ncol = pe3 + pe4 - 2
+ cnt = pe3 - 1
+
+ !! bottom edge
+ DO CONCURRENT(k1=2:pe3, ii=1:nrow)
+ ans(ii, k1 - 1) = (o1**k1) * L1(ii, k1) * L2(ii, 0)
+ END DO
+
+ !! top edge
+ DO CONCURRENT(k1=2:pe4, ii=1:nrow)
+ ans(ii, cnt + k1 - 1) = (o2**k1) * L1(ii, k1) * L2(ii, 1)
+ END DO
+
+END SUBROUTINE HorizontalEdgeBasis_Quadrangle2_
!----------------------------------------------------------------------------
! HorizontalEdgeBasisGradient_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2
-INTEGER(I4B) :: k1, cnt
-cnt = 0
-DO k1 = 2, pe3
- cnt = cnt + 1
- ans(:, cnt, 1) = dL1(:, k1) * L2(:, 0)
- ans(:, cnt, 2) = L1(:, k1) * dL2(:, 0)
-END DO
-DO k1 = 2, pe4
- cnt = cnt + 1
- ans(:, cnt, 1) = dL1(:, k1) * L2(:, 1)
- ans(:, cnt, 2) = L1(:, k1) * dL2(:, 1)
-END DO
-END PROCEDURE HorizontalEdgeBasisGradient_Quadrangle2
+PURE SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_(pe3, pe4, &
+ L1, L2, dL1, dL2, ans, dim1, dim2, dim3, pe3Orient, pe4Orient)
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on bottom vertical edge (e3), it should be greater than 1
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order on top vertical edge(e4), it should be greater than 1
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(L1, 1)
+ !! dim2 = pe3 + pe4 - 2
+ !! dim3 = 2
+ INTEGER(I4B), INTENT(IN) :: pe3Orient, pe4Orient
+ !! orientation of bottom and top horizontal edge
+
+ !! internal variable
+ INTEGER(I4B) :: k1, cnt, ii
+ REAL(DFP) :: o1, o2
+
+ o1 = REAL(pe3Orient, kind=DFP)
+
+ o2 = REAL(-pe4Orient, kind=DFP)
+ ! NOTE: Here we multiply by -1 because the top edge is oriented leftwards &
+ ! in master element
+
+ dim1 = SIZE(L1, 1)
+ dim2 = pe3 + pe4 - 2
+ dim3 = 2
+ cnt = pe3 - 1
+
+ !! bottom edge
+ DO CONCURRENT(k1=2:pe3, ii=1:dim1)
+ ans(ii, k1 - 1, 1) = (o1**(k1 - 1)) * dL1(ii, k1) * L2(ii, 0)
+ ans(ii, k1 - 1, 2) = (o1**(k1 - 1)) * L1(ii, k1) * dL2(ii, 0)
+ END DO
+
+ !! top edge
+ DO CONCURRENT(k1=2:pe4, ii=1:dim1)
+ ans(ii, cnt + k1 - 1, 1) = (o2**(k1 - 1)) * dL1(ii, k1) * L2(ii, 1)
+ ans(ii, cnt + k1 - 1, 2) = (o2**(k1 - 1)) * L1(ii, k1) * dL2(ii, 1)
+ END DO
+
+END SUBROUTINE HorizontalEdgeBasisGradient_Quadrangle2_
!----------------------------------------------------------------------------
! CellBasis_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE CellBasis_Quadrangle
+INTEGER(I4B) :: nrow, ncol
+CALL CellBasis_Quadrangle_(pb=pb, qb=qb, x=x, y=y, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE 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
+INTEGER(I4B), PARAMETER :: faceOrient(3) = [1, 1, 1]
-L1 = LobattoEvalAll(n=pb, x=x)
-L2 = LobattoEvalAll(n=qb, x=y)
+CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=nrow, ncol=ncol)
+CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=nrow, ncol=ncol)
-cnt = 0
+CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, ans=ans, nrow=nrow, &
+ ncol=ncol, faceOrient=faceOrient)
-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
+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)
+PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, &
+ faceOrient)
+ INTEGER(I4B), INTENT(IN) :: pb
+ !! order on bottom vertical edge (e3), it should be greater than 1
+ INTEGER(I4B), INTENT(IN) :: qb
+ !! order on top vertical edge(e4), it should be greater than 1
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(L1, 1), (pb - 1) * (qb - 1))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of rows and cols written to ans
+ INTEGER(I4B), INTENT(IN) :: faceOrient(3)
+ !! face orientation
+
+ !! Internal variables
+ INTEGER(I4B) :: k1, k2, ii, p, q
+ REAL(DFP) :: o1, o2
+
+ nrow = SIZE(L1, 1)
+ ncol = (pb - 1) * (qb - 1)
+
+ o1 = REAL(faceOrient(1), kind=DFP)
+ o2 = REAL(faceOrient(2), kind=DFP)
+
+ IF (faceOrient(3) .LT. 0_I4B) THEN
+ p = qb
+ q = pb
+ ELSE
+ p = pb
+ q = qb
+ END IF
+
+ DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow)
+ ans(ii, (q - 1) * (k1 - 2) + k2 - 1) = &
+ (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2)
END DO
-END DO
-END PROCEDURE CellBasis_Quadrangle2
+
+END SUBROUTINE CellBasis_Quadrangle2_
!----------------------------------------------------------------------------
! CellBasisGradient_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE CellBasisGradient_Quadrangle2
-INTEGER(I4B) :: k1, k2, cnt
-cnt = 0
-DO k1 = 2, pb
- DO k2 = 2, qb
- cnt = cnt + 1
- ans(:, cnt, 1) = dL1(:, k1) * L2(:, k2)
- ans(:, cnt, 2) = L1(:, k1) * dL2(:, k2)
+PURE SUBROUTINE CellBasisGradient_Quadrangle2_(pb, qb, L1, L2, &
+ dL1, dL2, ans, dim1, dim2, dim3, faceOrient)
+ INTEGER(I4B), INTENT(IN) :: pb
+ !! order on bottom vertical edge (e3), it should be greater than 1
+ INTEGER(I4B), INTENT(IN) :: qb
+ !! order on top vertical edge(e4), it should be greater than 1
+ REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
+ REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1=SIZE(L1, 1)
+ !! dim2=(pb - 1) * (qb - 1)
+ !! dim3=2
+ INTEGER(I4B), INTENT(IN) :: faceOrient(3)
+
+ !! internal variables
+ INTEGER(I4B) :: k1, k2, ii, p, q
+ REAL(DFP) :: o1, o2
+
+ dim1 = SIZE(L1, 1)
+ dim2 = (pb - 1) * (qb - 1)
+ dim3 = 2
+
+ o1 = REAL(faceOrient(1), kind=DFP)
+ o2 = REAL(faceOrient(2), kind=DFP)
+
+ IF (faceOrient(3) .LT. 0_I4B) THEN
+ p = qb
+ q = pb
+ ELSE
+ p = pb
+ q = qb
+ END IF
+
+ DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1)
+
+ ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 1) = &
+ (o1**(k1 - 1)) * (o2**k2) * dL1(ii, k1) * L2(ii, k2)
+
+ ans(ii, (q - 1) * (k1 - 2) + k2 - 1, 2) = &
+ (o1**k1) * (o2**(k2 - 1)) * L1(ii, k1) * dL2(ii, k2)
+
END DO
-END DO
-END PROCEDURE CellBasisGradient_Quadrangle2
+
+END SUBROUTINE CellBasisGradient_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))
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, &
+ qe1=qe1, qe2=qe2, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Quadrangle1_
+INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [1, 1]
+CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, qe1=qe1, &
+ qe2=qe2, xij=xij, pe3Orient=orient, pe4Orient=orient, &
+ qe1Orient=orient, qe2Orient=orient, faceOrient=faceOrient, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Quadrangle1_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Quadrangle2
+INTEGER(I4B) :: nrow, ncol
+
+CALL HeirarchicalBasis_Quadrangle1_(pb=p, pe3=p, pe4=p, &
+ qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Quadrangle2
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Quadrangle2_
+CALL HeirarchicalBasis_Quadrangle1_(pb=p, pe3=p, pe4=p, &
+ qb=q, qe1=q, qe2=q, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Quadrangle2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Quadrangle3
+INTEGER(I4B) :: nrow, ncol
+
+nrow = SIZE(xij, 2)
+ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1
+
+ALLOCATE (ans(1:nrow, 1:ncol))
+
+CALL HeirarchicalBasis_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, &
+ qe1=qe1, qe2=qe2, xij=xij, pe3Orient=pe3Orient, pe4Orient=pe4Orient, &
+ qe1Orient=qe1Orient, qe2Orient=qe2Orient, faceOrient=faceOrient, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+END PROCEDURE HeirarchicalBasis_Quadrangle3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Quadrangle3_
+INTEGER(I4B) :: a, b, indx(4), maxP, maxQ
+REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :)
+LOGICAL(LGT) :: isok, abool
+
+nrow = SIZE(xij, 2)
+! ncol = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1
+ncol = 0
maxP = MAX(pe3, pe4, pb)
maxQ = MAX(qe1, qe2, qb)
-L1 = LobattoEvalAll(n=maxP, x=xij(1, :))
-L2 = LobattoEvalAll(n=maxQ, x=xij(2, :))
+ALLOCATE (L1(1:nrow, 0:maxP), L2(1:nrow, 0:maxQ))
+
+CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2))
+CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2))
! Vertex basis function
+CALL VertexBasis_Quadrangle3_(L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2))
-ans(:, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2)
+ncol = indx(2)
! Edge basis function
+isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B)
+IF (isok) THEN
+ CALL VerticalEdgeBasis_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, L2=L2, &
+ ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), qe1Orient=qe1Orient, &
+ qe2Orient=qe2Orient)
-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)
+ ncol = ncol + indx(2)
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)
+isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B)
+IF (isok) THEN
+ CALL HorizontalEdgeBasis_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, L2=L2, &
+ ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), pe3Orient=pe3Orient, &
+ pe4Orient=pe4Orient)
+ ncol = ncol + indx(2)
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)
+isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B)
+IF (isok) THEN
+ CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, &
+ ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient)
+ ncol = ncol + indx(2)
END IF
-END PROCEDURE HeirarchicalBasis_Quadrangle1
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Quadrangle
-!----------------------------------------------------------------------------
+DEALLOCATE (L1, L2)
-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 PROCEDURE HeirarchicalBasis_Quadrangle3_
!----------------------------------------------------------------------------
! LagrangeEvallAll_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Quadrangle1
+INTEGER(I4B) :: tsize
+CALL LagrangeEvalAll_Quadrangle1_(order=order, x=x, xij=xij, &
+ ans=ans, tsize=tsize, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE LagrangeEvalAll_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Quadrangle1_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof
-INTEGER(I4B) :: degree(SIZE(xij, 2), 2)
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2))
+INTEGER(I4B) :: ii, basisType0, degree(SIZE(xij, 2), 2), indx(2)
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), &
+ x21(2, 1)
+
+tsize = SIZE(xij, 2)
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
- coeff0 = TRANSPOSE(coeff)
- ELSE
- coeff0 = TRANSPOSE(coeff)
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, &
+ beta=beta, lambda=lambda, &
+ ans=coeff, nrow=indx(1), ncol=indx(2))
END IF
+
+ ! coeff0 = TRANSPOSE(coeff)
+ coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize)
+
ELSE
- coeff0 = TRANSPOSE(LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & ))
+
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff0, nrow=indx(1), ncol=indx(2))
+
+ ! coeff0 = TRANSPOSE(coeff0)
+
END IF
SELECT CASE (basisType0)
CASE (Monomial)
- degree = LagrangeDegree_Quadrangle(order=order)
- tdof = SIZE(xij, 2)
+ CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
+#ifdef DEBUG_VER
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Quadrangle1", &
- & line=__LINE__, &
- & unitno=stderr)
+ IF (tsize .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Quadrangle1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
END IF
- DO ii = 1, tdof
- xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2)
+#endif
+
+ DO ii = 1, tsize
+ indx(1:2) = degree(ii, 1:2)
+ xx(1, ii) = x(1)**indx(1) * x(2)**indx(2)
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasis_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=RESHAPE(x, [2, 1]))
+ ! xx = HeirarchicalBasis_Quadrangle( &
+ x21(1:2, 1) = x(1:2)
+ CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, &
+ xij=x21, ans=xx, nrow=indx(1), ncol=indx(2))
CASE DEFAULT
- xx = TensorProdBasis_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=RESHAPE(x, [2, 1]), &
- & basisType1=basisType0, &
- & basisType2=basisType0, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda)
+ x21(1:2, 1) = x(1:2)
+ CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x21, &
+ basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, &
+ nrow=indx(1), ncol=indx(2))
END SELECT
-ans = MATMUL(coeff0, xx(1, :))
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :))
+END DO
-END PROCEDURE LagrangeEvalAll_Quadrangle1
+END PROCEDURE LagrangeEvalAll_Quadrangle1_
!----------------------------------------------------------------------------
-! LagrangeEvalAll_Quadrangle2
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Quadrangle2
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll_Quadrangle2_(order=order, x=x, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol, coeff=coeff, firstCall=firstCall, &
+ basisType=basisType, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE LagrangeEvalAll_Quadrangle2
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle2
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Quadrangle2_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof
-INTEGER(I4B) :: degree(SIZE(xij, 2), 2)
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2))
-REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2))
+INTEGER(I4B) :: ii, jj, basisType0, indx(2), degree(SIZE(xij, 2), 2)
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)) ,xx(SIZE(x, 2), SIZE(xij, 2)), &
+ aval
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
- coeff0 = coeff
- ELSE
- coeff0 = coeff
+
+ ! coeff = LagrangeCoeff_Quadrangle(&
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff, nrow=indx(1), ncol=indx(2))
END IF
+
+ coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol)
+
ELSE
- coeff0 = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
+
+ ! coeff0 = LagrangeCoeff_Quadrangle(&
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, &
+ nrow=indx(1), ncol=indx(2))
+
END IF
SELECT CASE (basisType0)
CASE (Monomial)
- degree = LagrangeDegree_Quadrangle(order=order)
- tdof = SIZE(xij, 2)
+ ! degree = LagrangeDegree_Quadrangle(order=order)
+ CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Quadrangle1", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+ IF (ncol .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Quadrangle1", file=__FILE__, line=__LINE__, &
+ unitno=stderr)
+ RETURN
END IF
+#endif
- DO ii = 1, tdof
- xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2)
+ DO ii = 1, ncol
+ indx(1:2) = degree(ii, 1:2)
+ DO jj = 1, nrow
+ aval = x(1, jj)**indx(1) * x(2, jj)**indx(2)
+ xx(jj, ii) = aval
+ END DO
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasis_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=x)
+ ! xx = HeirarchicalBasis_Quadrangle( &
+ CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, &
+ nrow=indx(1), ncol=indx(2))
CASE DEFAULT
- xx = TensorProdBasis_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=x, &
- & basisType1=basisType0, &
- & basisType2=basisType0, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda)
+ ! xx = TensorProdBasis_Quadrangle( &
+ CALL TensorProdBasis_Quadrangle_(p=order, q=order, xij=x, &
+ basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, &
+ nrow=indx(1), ncol=indx(2))
END SELECT
-ans = MATMUL(xx, coeff0)
+! ans = MATMUL(xx, coeff0)
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0)
-END PROCEDURE LagrangeEvalAll_Quadrangle2
+END PROCEDURE LagrangeEvalAll_Quadrangle2_
!----------------------------------------------------------------------------
! QuadraturePoint_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Quadrangle1
-ans = QuadraturePoint_Quadrangle2( &
- & p=order, &
- & q=order, &
- & quadType1=quadType, &
- & quadType2=quadType, &
- & xij=xij, &
- & refQuadrangle=refQuadrangle, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda &
- & )
+INTEGER(I4B) :: nips(1), nrow, ncol
+
+nips(1) = QuadratureNumber_Line(order=order, quadType=quadType)
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), 2)
+ELSE
+ nrow = 2
+END IF
+
+nrow = nrow + 1
+ncol = nips(1) * nips(1)
+
+ALLOCATE (ans(1:nrow, 1:ncol))
+
+CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, &
+ quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, &
+ xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, &
+ beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
END PROCEDURE QuadraturePoint_Quadrangle1
!----------------------------------------------------------------------------
@@ -1605,77 +1979,26 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Quadrangle2
-! internal variables
-REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), temp(:, :)
-INTEGER(I4B) :: ii, jj, kk, nsd, np, nq
-TYPE(String) :: astr
+INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol
-astr = TRIM(UpperCase(refQuadrangle))
-
-x = QuadraturePoint_Line( &
- & order=p, &
- & quadType=quadType1, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-np = SIZE(x, 2)
-
-y = QuadraturePoint_Line( &
- & order=q, &
- & quadType=quadType2, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-
-nq = SIZE(y, 2)
+nipsx(1) = QuadratureNumber_Line(order=p, quadType=quadType1)
+nipsy(1) = QuadratureNumber_Line(order=q, quadType=quadType2)
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
+ nrow = MAX(SIZE(xij, 1), 2)
ELSE
- nsd = 2
+ nrow = 2
END IF
-CALL Reallocate(ans, nsd + 1_I4B, np * nq)
-CALL Reallocate(temp, 3_I4B, np * nq)
+nrow = nrow + 1
+ncol = nipsx(1) * nipsy(1)
-kk = 0
-DO ii = 1, np
- DO jj = 1, nq
- kk = kk + 1
- temp(1, kk) = x(1, ii)
- temp(2, kk) = y(1, jj)
- temp(3, kk) = x(2, ii) * y(2, jj)
- END DO
-END DO
+ALLOCATE (ans(1:nrow, 1:ncol))
-IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( &
- & xin=temp(1:2, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4))
- ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( &
- & from="BIUNIT", to="QUADRANGLE", xij=xij)
-ELSE
- IF (astr%chars() .EQ. "UNIT") THEN
- ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( &
- & xin=temp(1:2, :))
- ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( &
- & from="BIUNIT", to="UNIT", xij=xij)
- ELSE
- ans = temp
- END IF
-END IF
-
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
-IF (ALLOCATED(x)) DEALLOCATE (x)
-IF (ALLOCATED(y)) DEALLOCATE (y)
+CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, &
+ quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, &
+ xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, &
+ beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE QuadraturePoint_Quadrangle2
@@ -1684,20 +2007,24 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Quadrangle3
-ans = QuadraturePoint_Quadrangle4( &
- & nipsx=nips, &
- & nipsy=nips, &
- & quadType1=quadType, &
- & quadType2=quadType, &
- & refQuadrangle=refQuadrangle, &
- & xij=xij, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda &
- & )
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), 2)
+ELSE
+ nrow = 2
+END IF
+
+nrow = nrow + 1
+ncol = nips(1) * nips(1)
+
+ALLOCATE (ans(1:nrow, 1:ncol))
+
+CALL QuadraturePoint_Quadrangle1_(nipsx=nips, nipsy=nips, &
+ quadType1=quadType, quadType2=quadType, refQuadrangle=refQuadrangle, &
+ xij=xij, alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, &
+ beta2=beta, lambda2=lambda, ans=ans, nrow=nrow, ncol=ncol)
+
END PROCEDURE QuadraturePoint_Quadrangle3
!----------------------------------------------------------------------------
@@ -1705,316 +2032,386 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Quadrangle4
-! internal variables
-REAL(DFP) :: x(2, nipsx(1)), y(2, nipsy(1)), temp(3, nipsy(1) * nipsx(1))
-INTEGER(I4B) :: ii, jj, kk, nsd, np, nq
-TYPE(String) :: astr
+INTEGER(I4B) :: nrow, ncol
-astr = TRIM(UpperCase(refQuadrangle))
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), 2)
+ELSE
+ nrow = 2
+END IF
-x = QuadraturePoint_Line( &
- & nips=nipsx, &
- & quadType=quadType1, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
+nrow = nrow + 1
+ncol = nipsx(1) * nipsy(1)
-np = SIZE(x, 2)
+ALLOCATE (ans(1:nrow, 1:ncol))
+
+CALL QuadraturePoint_Quadrangle1_(nipsx=nipsx, nipsy=nipsy, &
+ quadType1=quadType1, quadType2=quadType2, refQuadrangle=refQuadrangle, &
+ xij=xij, alpha1=alpha1, beta1=beta1, lambda1=lambda1, alpha2=alpha2, &
+ beta2=beta2, lambda2=lambda2, ans=ans, nrow=nrow, ncol=ncol)
+
+END PROCEDURE QuadraturePoint_Quadrangle4
-y = QuadraturePoint_Line( &
- & nips=nipsy, &
- & quadType=quadType2, &
- & xij=[-1.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Quadrangle1_
+! internal variables
+REAL(DFP) :: x(4, nipsx(1)), y(2, nipsy(1)), areal
+INTEGER(I4B) :: ii, jj, kk, nsd, np, nq
+CHARACTER(len=1) :: astr
-nq = SIZE(y, 2)
+REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2])
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
+ nsd = MAX(SIZE(xij, 1), 2)
ELSE
nsd = 2
END IF
-CALL Reallocate(ans, nsd + 1_I4B, np * nq)
+! CALL Reallocate(ans, nsd + 1_I4B, np * nq)
+nrow = nsd + 1
+ncol = nipsx(1) * nipsy(1)
-kk = 0
-DO ii = 1, np
- DO jj = 1, nq
- kk = kk + 1
- temp(1, kk) = x(1, ii)
- temp(2, kk) = y(1, jj)
- temp(3, kk) = x(2, ii) * y(2, jj)
- END DO
+CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadType1, xij=x12, &
+ layout="INCREASING", alpha=alpha1, beta=beta1, lambda=lambda1, ans=x, &
+ nrow=ii, ncol=np)
+
+CALL QuadraturePoint_Line_(nips=nipsy, quadType=quadType2, xij=x12, &
+ layout="INCREASING", alpha=alpha2, beta=beta2, lambda=lambda2, ans=y, &
+ nrow=ii, ncol=nq)
+
+DO CONCURRENT(ii=1:np, jj=1:nq)
+ ans(1, nq * (ii - 1) + jj) = x(1, ii)
+ ans(2, nq * (ii - 1) + jj) = y(1, jj)
+ ans(nrow, nq * (ii - 1) + jj) = x(2, ii) * y(2, jj)
END DO
IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromBiUnitQuadrangle2Quadrangle( &
- & xin=temp(1:2, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4))
- ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( &
- & from="BIUNIT", to="QUADRANGLE", xij=xij)
-ELSE
- IF (astr%chars() .EQ. "UNIT") THEN
- ans(1:nsd, :) = FromBiUnitQuadrangle2UnitQuadrangle( &
- & xin=temp(1:2, :))
- ans(nsd + 1, :) = temp(3, :) * JacobianQuadrangle( &
- & from="BIUNIT", to="UNIT", xij=xij)
- ELSE
- ans = temp
- END IF
+ CALL FromBiUnitQuadrangle2Quadrangle_(xin=ans(1:2, :), x1=xij(:, 1), &
+ x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, nrow=ii, ncol=jj)
+
+ areal = JacobianQuadrangle(from="BIUNIT", to="QUADRANGLE", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
END IF
-END PROCEDURE QuadraturePoint_Quadrangle4
+astr = UpperCase(refQuadrangle(1:1))
+IF (astr .EQ. "U") THEN
+ CALL FromBiUnitQuadrangle2UnitQuadrangle_(xin=ans(1:2, :), ans=ans, &
+ nrow=ii, ncol=jj)
+
+ areal = JacobianQuadrangle(from="BIUNIT", to="UNIT", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
+END IF
+
+END PROCEDURE QuadraturePoint_Quadrangle1_
!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Quadrangle
+!
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll_Quadrangle1_(order=order, x=x, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE LagrangeGradientEvalAll_Quadrangle1
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof, ai, bi
-INTEGER(I4B) :: degree(SIZE(xij, 2), 2)
+INTEGER(I4B) :: ii, basisType0, ai, bi, indx(3), degree(SIZE(xij, 2), 2), &
+ jj
REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), &
- & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br
+ xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br, areal, breal
+
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = 2
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
- coeff0 = coeff
- ELSE
- coeff0 = coeff
+
+ ! coeff = LagrangeCoeff_Quadrangle(&
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, ans=coeff, &
+ nrow=indx(1), ncol=indx(2))
END IF
+
+ coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2)
+
ELSE
- coeff0 = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
+
+ ! coeff0 = LagrangeCoeff_Quadrangle(&
+ CALL LagrangeCoeff_Quadrangle_(order=order, xij=xij, basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=coeff0, nrow=indx(1), &
+ ncol=indx(2))
END IF
SELECT CASE (basisType0)
CASE (Monomial)
- degree = LagrangeDegree_Quadrangle(order=order)
- tdof = SIZE(xij, 2)
+ ! degree = LagrangeDegree_Quadrangle(order=order)
+ CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
+
+#ifdef DEBUG_VER
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Quadrangle1", &
- & line=__LINE__, &
- & unitno=stderr)
+ IF (dim2 .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Quadrangle1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+ RETURN
END IF
- DO ii = 1, tdof
+#endif
+
+ DO ii = 1, dim2
ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B)
bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B)
ar = REAL(degree(ii, 1_I4B), DFP)
br = REAL(degree(ii, 2_I4B), DFP)
- xx(:, ii, 1) = (ar * x(1, :)**ai) * x(2, :)**degree(ii, 2)
- xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi)
+
+ indx(1:2) = degree(ii, 1:2)
+
+ DO jj = 1, dim1
+ areal = (ar * x(1, jj)**ai) * x(2, jj)**indx(2)
+ breal = x(1, jj)**indx(1) * (br * x(2, jj)**bi)
+ xx(jj, ii, 1) = areal
+ xx(jj, ii, 2) = breal
+
+ END DO
+
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasisGradient_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=x)
+ ! xx = HeirarchicalBasisGradient_Quadrangle( &
+ CALL HeirarchicalBasisGradient_Quadrangle_(p=order, q=order, xij=x, &
+ ans=xx, dim1=indx(1), dim2=indx(2), dim3=indx(3))
CASE DEFAULT
- xx = OrthogonalBasisGradient_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=x, &
- & basisType1=basisType0, &
- & basisType2=basisType0, &
- & alpha1=alpha, &
- & beta1=beta, &
- & lambda1=lambda, &
- & alpha2=alpha, &
- & beta2=beta, &
- & lambda2=lambda)
+ ! xx = OrthogonalBasisGradient_Quadrangle( &
+ CALL OrthogonalBasisGradient_Quadrangle_(p=order, q=order, xij=x, &
+ basisType1=basisType0, basisType2=basisType0, alpha1=alpha, beta1=beta, &
+ lambda1=lambda, alpha2=alpha, beta2=beta, lambda2=lambda, ans=xx, &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3))
END SELECT
DO ii = 1, 2
! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
- ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0)
+ ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0)
END DO
-END PROCEDURE LagrangeGradientEvalAll_Quadrangle1
+END PROCEDURE LagrangeGradientEvalAll_Quadrangle1_
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasisGradient_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))
-REAL(DFP) :: dL1(1:SIZE(xij, 2), 0:MAX(pe3, pe4, pb))
-REAL(DFP) :: dL2(1:SIZE(xij, 2), 0:MAX(qe1, qe2, qb))
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL HeirarchicalBasisGradient_Quadrangle1_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, &
+ qe1=qe1, qe2=qe2, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1_
+INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(3) = [1, 1, 1]
+
+CALL HeirarchicalBasisGradient_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, &
+ qe1=qe1, qe2=qe2, xij=xij, qe1Orient=orient, qe2Orient=orient, &
+ pe3Orient=orient, pe4Orient=orient, faceOrient=faceOrient, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle1_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL HeirarchicalBasisGradient_Quadrangle2_(p=p, q=q, xij=xij, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2_
+CALL HeirarchicalBasisGradient_Quadrangle1_(pb=p, pe3=p, pe4=p, qb=q, qe1=q, &
+ qe2=q, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle3
+INTEGER(I4B) :: dim1, dim2, dim3
+dim1 = SIZE(xij, 2)
+dim2 = pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1
+dim3 = 2
+
+ALLOCATE (ans(1:dim1, 1:dim2, 1:dim3))
+
+CALL HeirarchicalBasisGradient_Quadrangle3_(pb=pb, qb=qb, pe3=pe3, pe4=pe4, &
+ qe1=qe1, qe2=qe2, xij=xij, qe1Orient=qe1Orient, qe2Orient=qe2Orient, &
+ pe3Orient=pe3Orient, pe4Orient=pe4Orient, faceOrient=faceOrient, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle3_
+INTEGER(I4B) :: maxP, maxQ, indx(3)
+REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :), dL1(:, :), dL2(:, :)
+LOGICAL(LGT) :: isok
+
+dim1 = SIZE(xij, 2)
+dim2 = 0
+dim3 = 2
maxP = MAX(pe3, pe4, pb)
maxQ = MAX(qe1, qe2, qb)
-L1 = LobattoEvalAll(n=maxP, x=xij(1, :))
-L2 = LobattoEvalAll(n=maxQ, x=xij(2, :))
-dL1 = LobattoGradientEvalAll(n=maxP, x=xij(1, :))
-dL2 = LobattoGradientEvalAll(n=maxQ, x=xij(2, :))
+ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), &
+ dL1(1:dim1, 0:maxP), dL2(1:dim1, 0:maxQ))
-! Vertex basis function
-ans(:, 1:4, 1:2) = VertexBasisGradient_Quadrangle2( &
-& L1=L1, &
-& L2=L2, &
-& dL1=dL1, &
-& dL2=dL2 &
-& )
+CALL LobattoEvalAll_(n=maxP, x=xij(1, :), ans=L1, nrow=indx(1), ncol=indx(2))
+CALL LobattoEvalAll_(n=maxQ, x=xij(2, :), ans=L2, nrow=indx(1), ncol=indx(2))
+CALL LobattoGradientEvalAll_(n=maxP, x=xij(1, :), ans=dL1, nrow=indx(1), &
+ ncol=indx(2))
+CALL LobattoGradientEvalAll_(n=maxQ, x=xij(2, :), ans=dL2, nrow=indx(1), &
+ ncol=indx(2))
+
+CALL VertexBasisGradient_Quadrangle2_(L1=L1, L2=L2, dL1=dL1, dL2=dL2, &
+ ans=ans, dim1=indx(1), dim2=indx(2), dim3=indx(3))
+
+dim2 = indx(2)
+
+isok = (qe1 .GE. 2_I4B) .OR. (qe2 .GE. 2_I4B)
+
+IF (isok) THEN
+ CALL VerticalEdgeBasisGradient_Quadrangle2_(qe1=qe1, qe2=qe2, L1=L1, &
+ L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), qe1Orient=qe1Orient, qe2Orient=qe2Orient)
+
+ dim2 = dim2 + indx(2)
-! 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, 1:2) = VerticalEdgeBasisGradient_Quadrangle2( &
- & qe1=qe1, &
- & qe2=qe2, &
- & L1=L1, &
- & L2=L2, &
- & dL1=dL1, &
- & dL2=dL2 &
- & )
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, 1:2) = HorizontalEdgeBasisGradient_Quadrangle2( &
- & pe3=pe3, &
- & pe4=pe4, &
- & L1=L1, &
- & L2=L2, &
- & dL1=dL1, &
- & dL2=dL2 &
- & )
+isok = (pe3 .GE. 2_I4B) .OR. (pe4 .GE. 2_I4B)
+IF (isok) THEN
+ CALL HorizontalEdgeBasisGradient_Quadrangle2_(pe3=pe3, pe4=pe4, L1=L1, &
+ L2=L2, dL1=dL1, dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), pe3Orient=pe3Orient, pe4Orient=pe4Orient)
+ dim2 = dim2 + indx(2)
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, 1:2) = CellBasisGradient_Quadrangle2( &
- & pb=pb, &
- & qb=qb, &
- & L1=L1, &
- & L2=L2, &
- & dL1=dL1, &
- & dL2=dL2 &
- & )
+isok = (pb .GE. 2_I4B) .OR. (qb .GE. 2_I4B)
+IF (isok) THEN
+ CALL CellBasisGradient_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, dL1=dL1, &
+ dL2=dL2, ans=ans(:, dim2 + 1:, :), dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), faceOrient=faceOrient)
+
+ dim2 = dim2 + indx(2)
END IF
-END PROCEDURE HeirarchicalBasisGradient_Quadrangle1
-!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Quadrangle
-!----------------------------------------------------------------------------
+DEALLOCATE (L1, L2, dL1, dL2)
-MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle2
-ans = HeirarchicalBasisGradient_Quadrangle1( &
- & pb=p, &
- & pe3=p, &
- & pe4=p, &
- & qb=q, &
- & qe1=q, &
- & qe2=q, &
- & xij=xij)
-END PROCEDURE HeirarchicalBasisGradient_Quadrangle2
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_
!----------------------------------------------------------------------------
! TensorProdBasisGradient_Quadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2))
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL TensorProdBasisGradient_Quadrangle1_(p=p, q=q, xij=xij, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3, basisType1=basisType1, &
+ basisType2=basisType2, alpha1=alpha1, beta1=beta1, lambda1=lambda1, &
+ alpha2=alpha2, beta2=beta2, lambda2=lambda2)
+END PROCEDURE TensorProdBasisGradient_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1_
REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1)
REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1)
-INTEGER(I4B) :: ii, k1, k2, cnt
+INTEGER(I4B) :: k1, k2, cnt, indx(3)
-x = xij(1, :)
-y = xij(2, :)
+dim1 = SIZE(xij, 2)
+dim2 = (p + 1) * (q + 1)
+dim3 = 2
-P1 = BasisEvalAll_Line( &
- & order=p, &
- & x=x, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-Q1 = BasisEvalAll_Line( &
- & order=q, &
- & x=y, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
-
-dP1 = BasisGradientEvalAll_Line( &
- & order=p, &
- & x=x, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1)
-
-dQ1 = BasisGradientEvalAll_Line( &
- & order=q, &
- & x=y, &
- & refLine="BIUNIT", &
- & basisType=basisType1, &
- & alpha=alpha2, &
- & beta=beta2, &
- & lambda=lambda2)
+! P1
+CALL BasisEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, &
+ ans=P1, nrow=indx(1), ncol=indx(2))
+
+! Q1 = BasisEvalAll_Line( &
+CALL BasisEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=Q1, &
+ nrow=indx(1), ncol=indx(2))
+
+! dP1 = BasisGradientEvalAll_Line( &
+CALL BasisGradientEvalAll_Line_(order=p, x=xij(1, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha1, beta=beta1, lambda=lambda1, ans=dP1, &
+ nrow=indx(1), ncol=indx(2))
+
+! dQ1 = BasisGradientEvalAll_Line( &
+CALL BasisGradientEvalAll_Line_(order=q, x=xij(2, :), refLine="BIUNIT", &
+ basisType=basisType1, alpha=alpha2, beta=beta2, lambda=lambda2, ans=dQ1, &
+ nrow=indx(1), ncol=indx(2))
cnt = 0
DO k2 = 1, q + 1
+
DO k1 = 1, p + 1
cnt = cnt + 1
- ans(:, cnt, 1) = dP1(:, k1) * Q1(:, k2)
- ans(:, cnt, 2) = P1(:, k1) * dQ1(:, k2)
+ ans(1:dim1, cnt, 1) = dP1(1:dim1, k1) * Q1(1:dim1, k2)
+ ans(1:dim1, cnt, 2) = P1(1:dim1, k1) * dQ1(1:dim1, k2)
END DO
+
END DO
-END PROCEDURE TensorProdBasisGradient_Quadrangle1
+END PROCEDURE TensorProdBasisGradient_Quadrangle1_
!----------------------------------------------------------------------------
! QuadraturePoint_Quadrangle3
diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90
index 810e3c6cb..b1fe4e11e 100644
--- a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90
+++ b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90
@@ -17,17 +17,21 @@
MODULE QuadraturePoint_Tetrahedron_Solin
USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
-PRIVATE
+
+PRIVATE
+
PUBLIC :: QuadraturePointTetrahedronSolin
PUBLIC :: QuadratureOrderTetrahedronSolin
PUBLIC :: QuadratureNumberTetrahedronSolin
-INTEGER( I4B ), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN=21
-
-CONTAINS
+
+INTEGER(I4B), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN = 21
+
+CONTAINS
!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans)
@@ -69,7 +73,7 @@ PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans)
END FUNCTION QuadratureOrderTetrahedronSolin
!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans)
@@ -123,3327 +127,87 @@ PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans)
END FUNCTION QuadratureNumberTetrahedronSolin
!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
-
-PURE FUNCTION QuadraturePointTetrahedronSolin(order) RESULT(ans)
- REAL(DFP), ALLOCATABLE :: ans(:, :)
+
+PURE SUBROUTINE QuadraturePointTetrahedronSolin(order, ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: order
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
SELECT CASE (order)
CASE (0, 1)
- ans = QP_Tetrahedron_Order1()
+ CALL QP_Tetrahedron_Order1(ans=ans, nrow=nrow, ncol=ncol)
CASE (2)
- ans = QP_Tetrahedron_Order2()
+ CALL QP_Tetrahedron_Order2(ans=ans, nrow=nrow, ncol=ncol)
CASE (3)
- ans = QP_Tetrahedron_Order3()
+ CALL QP_Tetrahedron_Order3(ans=ans, nrow=nrow, ncol=ncol)
CASE (4)
- ans = QP_Tetrahedron_Order4()
+ CALL QP_Tetrahedron_Order4(ans=ans, nrow=nrow, ncol=ncol)
CASE (5)
- ans = QP_Tetrahedron_Order5()
+ CALL QP_Tetrahedron_Order5(ans=ans, nrow=nrow, ncol=ncol)
CASE (6)
- ans = QP_Tetrahedron_Order6()
+ CALL QP_Tetrahedron_Order6(ans=ans, nrow=nrow, ncol=ncol)
CASE (7)
- ans = QP_Tetrahedron_Order7()
+ CALL QP_Tetrahedron_Order7(ans=ans, nrow=nrow, ncol=ncol)
CASE (8)
- ans = QP_Tetrahedron_Order8()
+ CALL QP_Tetrahedron_Order8(ans=ans, nrow=nrow, ncol=ncol)
CASE (9)
- ans = QP_Tetrahedron_Order9()
+ CALL QP_Tetrahedron_Order9(ans=ans, nrow=nrow, ncol=ncol)
CASE (10)
- ans = QP_Tetrahedron_Order10()
+ CALL QP_Tetrahedron_Order10(ans=ans, nrow=nrow, ncol=ncol)
CASE (11)
- ans = QP_Tetrahedron_Order11()
+ CALL QP_Tetrahedron_Order11(ans=ans, nrow=nrow, ncol=ncol)
CASE (12)
- ans = QP_Tetrahedron_Order12()
+ CALL QP_Tetrahedron_Order12(ans=ans, nrow=nrow, ncol=ncol)
CASE (13)
- ans = QP_Tetrahedron_Order13()
+ CALL QP_Tetrahedron_Order13(ans=ans, nrow=nrow, ncol=ncol)
CASE (14)
- ans = QP_Tetrahedron_Order14()
+ CALL QP_Tetrahedron_Order14(ans=ans, nrow=nrow, ncol=ncol)
CASE (15)
- ans = QP_Tetrahedron_Order15()
+ CALL QP_Tetrahedron_Order15(ans=ans, nrow=nrow, ncol=ncol)
CASE (16)
- ans = QP_Tetrahedron_Order16()
+ CALL QP_Tetrahedron_Order16(ans=ans, nrow=nrow, ncol=ncol)
CASE (17)
- ans = QP_Tetrahedron_Order17()
+ CALL QP_Tetrahedron_Order17(ans=ans, nrow=nrow, ncol=ncol)
CASE (18)
- ans = QP_Tetrahedron_Order18()
+ CALL QP_Tetrahedron_Order18(ans=ans, nrow=nrow, ncol=ncol)
CASE (19)
- ans = QP_Tetrahedron_Order19()
+ CALL QP_Tetrahedron_Order19(ans=ans, nrow=nrow, ncol=ncol)
CASE (20)
- ans = QP_Tetrahedron_Order20()
+ CALL QP_Tetrahedron_Order20(ans=ans, nrow=nrow, ncol=ncol)
CASE (21)
- ans = QP_Tetrahedron_Order21()
+ CALL QP_Tetrahedron_Order21(ans=ans, nrow=nrow, ncol=ncol)
END SELECT
-END FUNCTION QuadraturePointTetrahedronSolin
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order1() RESULT(ans)
- REAL(DFP) :: ans(4, 1)
- ans = RESHAPE([ &
- & 0.250000000000000, 0.250000000000000, 0.250000000000000, 0.166666666666667 &
- & ], [4, 1])
-END FUNCTION QP_Tetrahedron_Order1
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order2() RESULT(ans)
- REAL(DFP) :: ans(4, 4)
- ans = RESHAPE([ &
- & 0.585410196624969, 0.138196601125011, 0.138196601125011, 0.041666666666667, &
- & 0.138196601125011, 0.138196601125011, 0.138196601125011, 0.041666666666667, &
- & 0.138196601125011, 0.138196601125011, 0.585410196624969, 0.041666666666667, &
- & 0.138196601125011, 0.585410196624969, 0.138196601125011, 0.041666666666667 &
- & ], [4, 4])
-END FUNCTION QP_Tetrahedron_Order2
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order3() RESULT(ans)
- REAL(DFP) :: ans(4, 5)
- ans = RESHAPE([ &
- & 0.250000000000000, 0.250000000000000, 0.250000000000000, -0.133333333333333, &
- & 0.500000000000000, 0.166666666666667, 0.166666666666667, 0.075000000000000, &
- & 0.166666666666667, 0.166666666666667, 0.166666666666667, 0.075000000000000, &
- & 0.166666666666667, 0.166666666666667, 0.500000000000000, 0.075000000000000, &
- & 0.166666666666667, 0.500000000000000, 0.166666666666667, 0.075000000000000 &
- & ], [4, 5])
-END FUNCTION QP_Tetrahedron_Order3
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-PURE FUNCTION QP_Tetrahedron_Order4() RESULT(ans)
- REAL(DFP) :: ans(4, 11)
- ans = RESHAPE([ &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222, &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222, &
- & 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888, &
- & 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888, &
- & 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888, &
- & 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888, &
- & 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888, &
- & 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 &
- & ], [4, 11])
-END FUNCTION QP_Tetrahedron_Order4
+CONTAINS
+
+#include "./include/Tetrahedron/order1.F90"
+#include "./include/Tetrahedron/order2.F90"
+#include "./include/Tetrahedron/order3.F90"
+#include "./include/Tetrahedron/order4.F90"
+#include "./include/Tetrahedron/order5.F90"
+#include "./include/Tetrahedron/order6.F90"
+#include "./include/Tetrahedron/order7.F90"
+#include "./include/Tetrahedron/order8.F90"
+#include "./include/Tetrahedron/order9.F90"
+#include "./include/Tetrahedron/order10.F90"
+#include "./include/Tetrahedron/order11.F90"
+#include "./include/Tetrahedron/order12.F90"
+#include "./include/Tetrahedron/order13.F90"
+#include "./include/Tetrahedron/order14.F90"
+#include "./include/Tetrahedron/order15.F90"
+#include "./include/Tetrahedron/order16.F90"
+#include "./include/Tetrahedron/order17.F90"
+#include "./include/Tetrahedron/order18.F90"
+#include "./include/Tetrahedron/order19.F90"
+#include "./include/Tetrahedron/order20.F90"
+#include "./include/Tetrahedron/order21.F90"
+
+END SUBROUTINE QuadraturePointTetrahedronSolin
!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order5() RESULT(ans)
- REAL(DFP) :: ans(4, 14)
- ans = RESHAPE([ &
- & 0.0927352503109, 0.0927352503109, 0.0927352503109 , 0.01224884051940, &
- & 0.7217942490670, 0.0927352503109, 0.0927352503109 , 0.01224884051940, &
- & 0.0927352503109, 0.7217942490670, 0.0927352503109 , 0.01224884051940, &
- & 0.0927352503109, 0.0927352503109, 0.7217942490670 , 0.01224884051940, &
- & 0.3108859192630, 0.3108859192630, 0.3108859192630 , 0.01878132095300, &
- & 0.0673422422101, 0.3108859192630, 0.3108859192630 , 0.01878132095300, &
- & 0.3108859192630, 0.0673422422101, 0.3108859192630 , 0.01878132095300, &
- & 0.3108859192630, 0.3108859192630, 0.0673422422101 , 0.01878132095300, &
- & 0.4544962958740, 0.4544962958740, 0.0455037041256 , 0.00709100346285, &
- & 0.4544962958740, 0.0455037041256, 0.4544962958740 , 0.00709100346285, &
- & 0.0455037041256, 0.4544962958740, 0.4544962958740 , 0.00709100346285, &
- & 0.4544962958740, 0.0455037041256, 0.0455037041256 , 0.00709100346285, &
- & 0.0455037041256, 0.4544962958740, 0.0455037041256 , 0.00709100346285, &
- & 0.0455037041256, 0.0455037041256, 0.4544962958740 , 0.00709100346285 &
- & ], [4, 14])
-END FUNCTION QP_Tetrahedron_Order5
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order6() RESULT(ans)
- REAL(DFP) :: ans(4, 24)
- ans = RESHAPE([ &
- & 0.2146028712590, 0.2146028712590, 0.2146028712590 , 0.006653791709700, &
- & 0.3561913862230, 0.2146028712590, 0.2146028712590 , 0.006653791709700, &
- & 0.2146028712590, 0.3561913862230, 0.2146028712590 , 0.006653791709700, &
- & 0.2146028712590, 0.2146028712590, 0.3561913862230 , 0.006653791709700, &
- & 0.0406739585346, 0.0406739585346, 0.0406739585346 , 0.001679535175883, &
- & 0.8779781243960, 0.0406739585346, 0.0406739585346 , 0.001679535175883, &
- & 0.0406739585346, 0.8779781243960, 0.0406739585346 , 0.001679535175883, &
- & 0.0406739585346, 0.0406739585346, 0.8779781243960 , 0.001679535175883, &
- & 0.3223378901420, 0.3223378901420, 0.3223378901420 , 0.009226196923950, &
- & 0.0329863295732, 0.3223378901420, 0.3223378901420 , 0.009226196923950, &
- & 0.3223378901420, 0.0329863295732, 0.3223378901420 , 0.009226196923950, &
- & 0.3223378901420, 0.3223378901420, 0.0329863295732 , 0.009226196923950, &
- & 0.0636610018750, 0.0636610018750, 0.2696723314580 , 0.008035714285717, &
- & 0.0636610018750, 0.2696723314580, 0.0636610018750 , 0.008035714285717, &
- & 0.0636610018750, 0.0636610018750, 0.6030056647920 , 0.008035714285717, &
- & 0.0636610018750, 0.6030056647920, 0.0636610018750 , 0.008035714285717, &
- & 0.0636610018750, 0.2696723314580, 0.6030056647920 , 0.008035714285717, &
- & 0.0636610018750, 0.6030056647920, 0.2696723314580 , 0.008035714285717, &
- & 0.2696723314580, 0.0636610018750, 0.0636610018750 , 0.008035714285717, &
- & 0.2696723314580, 0.0636610018750, 0.6030056647920 , 0.008035714285717, &
- & 0.2696723314580, 0.6030056647920, 0.0636610018750 , 0.008035714285717, &
- & 0.6030056647920, 0.0636610018750, 0.2696723314580 , 0.008035714285717, &
- & 0.6030056647920, 0.0636610018750, 0.0636610018750 , 0.008035714285717, &
- & 0.6030056647920, 0.2696723314580, 0.0636610018750 , 0.008035714285717 &
- & ], [4, 24])
-END FUNCTION QP_Tetrahedron_Order6
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order7() RESULT(ans)
- REAL(DFP) :: ans(4, 31)
- ans = RESHAPE([ &
- & 0.50000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, &
- & 0.50000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, &
- & 0.00000000000000, 0.50000000000000, 0.50000000000000 , +0.000970017636685, &
- & 0.00000000000000, 0.00000000000000, 0.50000000000000 , +0.000970017636685, &
- & 0.00000000000000, 0.50000000000000, 0.00000000000000 , +0.000970017636685, &
- & 0.50000000000000, 0.00000000000000, 0.00000000000000 , +0.000970017636685, &
- & 0.25000000000000, 0.25000000000000, 0.25000000000000 , +0.018264223466167, &
- & 0.07821319233030, 0.07821319233030, 0.07821319233030 , +0.010599941524417, &
- & 0.07821319233030, 0.07821319233030, 0.76536042300900 , +0.010599941524417, &
- & 0.07821319233030, 0.76536042300900, 0.07821319233030 , +0.010599941524417, &
- & 0.76536042300900, 0.07821319233030, 0.07821319233030 , +0.010599941524417, &
- & 0.12184321666400, 0.12184321666400, 0.12184321666400 , -0.062517740114333, &
- & 0.12184321666400, 0.12184321666400, 0.63447035000800 , -0.062517740114333, &
- & 0.12184321666400, 0.63447035000800, 0.12184321666400 , -0.062517740114333, &
- & 0.63447035000800, 0.12184321666400, 0.12184321666400 , -0.062517740114333, &
- & 0.33253916444600, 0.33253916444600, 0.33253916444600 , +0.004891425263067, &
- & 0.33253916444600, 0.33253916444600, 0.00238250666074 , +0.004891425263067, &
- & 0.33253916444600, 0.00238250666074, 0.33253916444600 , +0.004891425263067, &
- & 0.00238250666074, 0.33253916444600, 0.33253916444600 , +0.004891425263067, &
- & 0.10000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, &
- & 0.10000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000, &
- & 0.10000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, &
- & 0.10000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, &
- & 0.10000000000000, 0.20000000000000, 0.60000000000000 , +0.027557319224000, &
- & 0.10000000000000, 0.60000000000000, 0.20000000000000 , +0.027557319224000, &
- & 0.20000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, &
- & 0.20000000000000, 0.10000000000000, 0.60000000000000 , +0.027557319224000, &
- & 0.20000000000000, 0.60000000000000, 0.10000000000000 , +0.027557319224000, &
- & 0.60000000000000, 0.10000000000000, 0.20000000000000 , +0.027557319224000, &
- & 0.60000000000000, 0.10000000000000, 0.10000000000000 , +0.027557319224000, &
- & 0.60000000000000, 0.20000000000000, 0.10000000000000 , +0.027557319224000 &
- & ], [4, 31])
-END FUNCTION QP_Tetrahedron_Order7
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order8() RESULT(ans)
- REAL(DFP) :: ans(4, 43)
- ans = RESHAPE([ &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.020500188658667, &
- & 0.2068299316110, 0.2068299316110, 0.2068299316110 , +0.014250305822867, &
- & 0.2068299316110, 0.2068299316110, 0.3795102051680 , +0.014250305822867, &
- & 0.2068299316110, 0.3795102051680, 0.2068299316110 , +0.014250305822867, &
- & 0.3795102051680, 0.2068299316110, 0.2068299316110 , +0.014250305822867, &
- & 0.0821035883105, 0.0821035883105, 0.0821035883105 , +0.001967033313133, &
- & 0.0821035883105, 0.0821035883105, 0.7536892350680 , +0.001967033313133, &
- & 0.0821035883105, 0.7536892350680, 0.0821035883105 , +0.001967033313133, &
- & 0.7536892350680, 0.0821035883105, 0.0821035883105 , +0.001967033313133, &
- & 0.0057819505052, 0.0057819505052, 0.0057819505052 , +0.000169834109093, &
- & 0.0057819505052, 0.0057819505052, 0.9826541484840 , +0.000169834109093, &
- & 0.0057819505052, 0.9826541484840, 0.0057819505052 , +0.000169834109093, &
- & 0.9826541484840, 0.0057819505052, 0.0057819505052 , +0.000169834109093, &
- & 0.0505327400189, 0.0505327400189, 0.4494672599810 , +0.004579683824467, &
- & 0.0505327400189, 0.4494672599810, 0.0505327400189 , +0.004579683824467, &
- & 0.4494672599810, 0.0505327400189, 0.0505327400189 , +0.004579683824467, &
- & 0.0505327400189, 0.4494672599810, 0.4494672599810 , +0.004579683824467, &
- & 0.4494672599810, 0.0505327400189, 0.4494672599810 , +0.004579683824467, &
- & 0.4494672599810, 0.4494672599810, 0.0505327400189 , +0.004579683824467, &
- & 0.2290665361170, 0.2290665361170, 0.0356395827885 , +0.005704485808683, &
- & 0.2290665361170, 0.0356395827885, 0.2290665361170 , +0.005704485808683, &
- & 0.2290665361170, 0.2290665361170, 0.5062273449780 , +0.005704485808683, &
- & 0.2290665361170, 0.5062273449780, 0.2290665361170 , +0.005704485808683, &
- & 0.2290665361170, 0.0356395827885, 0.5062273449780 , +0.005704485808683, &
- & 0.2290665361170, 0.5062273449780, 0.0356395827885 , +0.005704485808683, &
- & 0.0356395827885, 0.2290665361170, 0.2290665361170 , +0.005704485808683, &
- & 0.0356395827885, 0.2290665361170, 0.5062273449780 , +0.005704485808683, &
- & 0.0356395827885, 0.5062273449780, 0.2290665361170 , +0.005704485808683, &
- & 0.5062273449780, 0.2290665361170, 0.0356395827885 , +0.005704485808683, &
- & 0.5062273449780, 0.2290665361170, 0.2290665361170 , +0.005704485808683, &
- & 0.5062273449780, 0.0356395827885, 0.2290665361170 , +0.005704485808683, &
- & 0.0366077495532, 0.0366077495532, 0.1904860419350 , +0.002140519141167, &
- & 0.0366077495532, 0.1904860419350, 0.0366077495532 , +0.002140519141167, &
- & 0.0366077495532, 0.0366077495532, 0.7362984589590 , +0.002140519141167, &
- & 0.0366077495532, 0.7362984589590, 0.0366077495532 , +0.002140519141167, &
- & 0.0366077495532, 0.1904860419350, 0.7362984589590 , +0.002140519141167, &
- & 0.0366077495532, 0.7362984589590, 0.1904860419350 , +0.002140519141167, &
- & 0.1904860419350, 0.0366077495532, 0.0366077495532 , +0.002140519141167, &
- & 0.1904860419350, 0.0366077495532, 0.7362984589590 , +0.002140519141167, &
- & 0.1904860419350, 0.7362984589590, 0.0366077495532 , +0.002140519141167, &
- & 0.7362984589590, 0.0366077495532, 0.1904860419350 , +0.002140519141167, &
- & 0.7362984589590, 0.0366077495532, 0.0366077495532 , +0.002140519141167, &
- & 0.7362984589590, 0.1904860419350, 0.0366077495532 , +0.002140519141167 &
- & ], [4, 43])
-END FUNCTION QP_Tetrahedron_Order8
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order9() RESULT(ans)
- REAL(DFP) :: ans(4, 53)
- ans = RESHAPE([ &
- & +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167, &
- & +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083, &
- & +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083, &
- & +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083, &
- & +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083, &
- & +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500, &
- & +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500, &
- & +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500, &
- & +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500, &
- & +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167, &
- & +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167, &
- & +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167, &
- & +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167, &
- & +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500, &
- & +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500, &
- & +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500, &
- & +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500, &
- & +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500, &
- & +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500, &
- & +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500, &
- & +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500, &
- & +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500, &
- & +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500, &
- & +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500, &
- & +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500, &
- & +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500, &
- & +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500, &
- & +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500, &
- & +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500, &
- & +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667, &
- & +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667, &
- & +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667, &
- & +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667, &
- & +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667, &
- & +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667, &
- & +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667, &
- & +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667, &
- & +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667, &
- & +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667, &
- & +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667, &
- & +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667, &
- & -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557, &
- & -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557, &
- & -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557, &
- & -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557, &
- & -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557, &
- & -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557, &
- & +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557, &
- & +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557, &
- & +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557, &
- & +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557, &
- & +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557, &
- & +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 &
- & ], [4, 53])
-END FUNCTION QP_Tetrahedron_Order9
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order10() RESULT(ans)
- REAL(DFP) :: ans(4, 126)
- ans = QP_Tetrahedron_Order11()
-END FUNCTION QP_Tetrahedron_Order10
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order11() RESULT(ans)
- REAL(DFP) :: ans(4, 126)
- ans = RESHAPE([ &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000, &
- & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000, &
- & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000, &
- & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000, &
- & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000, &
- & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000, &
- & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000, &
- & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000, &
- & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000, &
- & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000, &
- & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000, &
- & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000, &
- & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000, &
- & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000, &
- & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000, &
- & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000, &
- & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000, &
- & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000, &
- & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000, &
- & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000, &
- & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000, &
- & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000, &
- & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000, &
- & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000, &
- & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000, &
- & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000, &
- & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000, &
- & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000, &
- & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000, &
- & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000, &
- & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000, &
- & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000, &
- & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000, &
- & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000, &
- & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000, &
- & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000, &
- & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000, &
- & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000, &
- & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000, &
- & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000, &
- & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000, &
- & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000, &
- & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000, &
- & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000, &
- & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000, &
- & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000, &
- & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000, &
- & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000, &
- & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000, &
- & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000, &
- & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000, &
- & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000, &
- & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000, &
- & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500, &
- & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500, &
- & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500, &
- & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500, &
- & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500, &
- & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500, &
- & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500, &
- & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500, &
- & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500, &
- & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500, &
- & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500, &
- & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500, &
- & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500, &
- & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500, &
- & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, &
- & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500, &
- & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500, &
- & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500, &
- & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500, &
- & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500, &
- & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500, &
- & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500, &
- & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500, &
- & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500, &
- & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500, &
- & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500, &
- & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500, &
- & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500, &
- & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500, &
- & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500, &
- & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500, &
- & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500, &
- & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500, &
- & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500, &
- & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, &
- & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, &
- & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, &
- & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, &
- & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.4062316284e-05 &
- & ], [4, 126])
-END FUNCTION QP_Tetrahedron_Order11
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order12() RESULT(ans)
- REAL(DFP) :: ans(4, 210)
- ans = QP_Tetrahedron_Order13()
-END FUNCTION QP_Tetrahedron_Order12
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order13() RESULT(ans)
- REAL(DFP) :: ans(4, 210)
- ans = RESHAPE([ &
- & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500, &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333, &
- & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333, &
- & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333, &
- & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333, &
- & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333, &
- & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333, &
- & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333, &
- & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333, &
- & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333, &
- & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333, &
- & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333, &
- & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333, &
- & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333, &
- & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333, &
- & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333, &
- & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333, &
- & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333, &
- & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333, &
- & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333, &
- & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333, &
- & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333, &
- & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333, &
- & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333, &
- & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333, &
- & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333, &
- & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333, &
- & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333, &
- & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333, &
- & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333, &
- & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333, &
- & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333, &
- & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333, &
- & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333, &
- & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333, &
- & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333, &
- & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333, &
- & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333, &
- & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333, &
- & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333, &
- & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333, &
- & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333, &
- & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333, &
- & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333, &
- & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333, &
- & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333, &
- & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333, &
- & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333, &
- & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333, &
- & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333, &
- & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333, &
- & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333, &
- & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333, &
- & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333, &
- & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333, &
- & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333, &
- & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333, &
- & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333, &
- & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333, &
- & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333, &
- & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333, &
- & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333, &
- & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333, &
- & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333, &
- & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333, &
- & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333, &
- & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333, &
- & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333, &
- & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, &
- & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333, &
- & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333, &
- & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333, &
- & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333, &
- & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333, &
- & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333, &
- & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333, &
- & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333, &
- & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333, &
- & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333, &
- & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333, &
- & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333, &
- & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333, &
- & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333, &
- & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333, &
- & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333, &
- & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333, &
- & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333, &
- & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333, &
- & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, &
- & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, &
- & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, &
- & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, &
- & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 &
- & ], [4, 210])
-END FUNCTION
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order14() RESULT(ans)
- REAL(DFP) :: ans(4, 330)
- ans = QP_Tetrahedron_Order15()
-END FUNCTION
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order15() RESULT(ans)
- REAL(DFP) :: ans(4, 330)
- ans = RESHAPE([ &
- & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667, &
- & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667, &
- & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667, &
- & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667, &
- & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667, &
- & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667, &
- & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667, &
- & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667, &
- & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667, &
- & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667, &
- & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667, &
- & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667, &
- & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667, &
- & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667, &
- & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667, &
- & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667, &
- & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667, &
- & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667, &
- & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667, &
- & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667, &
- & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667, &
- & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667, &
- & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667, &
- & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667, &
- & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667, &
- & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667, &
- & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667, &
- & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667, &
- & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667, &
- & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667, &
- & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667, &
- & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667, &
- & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667, &
- & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667, &
- & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667, &
- & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667, &
- & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667, &
- & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667, &
- & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667, &
- & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667, &
- & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667, &
- & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667, &
- & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667, &
- & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667, &
- & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667, &
- & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667, &
- & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667, &
- & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667, &
- & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667, &
- & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667, &
- & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667, &
- & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667, &
- & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667, &
- & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667, &
- & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667, &
- & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667, &
- & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667, &
- & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667, &
- & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667, &
- & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667, &
- & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667, &
- & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667, &
- & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667, &
- & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667, &
- & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667, &
- & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667, &
- & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667, &
- & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667, &
- & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667, &
- & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667, &
- & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667, &
- & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667, &
- & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667, &
- & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667, &
- & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667, &
- & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667, &
- & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667, &
- & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667, &
- & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667, &
- & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667, &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333, &
- & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333, &
- & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333, &
- & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333, &
- & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333, &
- & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333, &
- & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333, &
- & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333, &
- & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333, &
- & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333, &
- & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333, &
- & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333, &
- & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333, &
- & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333, &
- & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333, &
- & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333, &
- & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333, &
- & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333, &
- & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333, &
- & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333, &
- & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333, &
- & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333, &
- & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333, &
- & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333, &
- & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333, &
- & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333, &
- & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333, &
- & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333, &
- & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333, &
- & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333, &
- & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333, &
- & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333, &
- & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333, &
- & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333, &
- & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333, &
- & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333, &
- & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333, &
- & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333, &
- & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333, &
- & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333, &
- & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333, &
- & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333, &
- & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333, &
- & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333, &
- & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333, &
- & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333, &
- & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333, &
- & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333, &
- & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333, &
- & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333, &
- & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333, &
- & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333, &
- & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333, &
- & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833, &
- & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833, &
- & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833, &
- & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833, &
- & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833, &
- & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833, &
- & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833, &
- & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833, &
- & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833, &
- & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833, &
- & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833, &
- & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833, &
- & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833, &
- & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833, &
- & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, &
- & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833, &
- & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833, &
- & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833, &
- & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833, &
- & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833, &
- & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833, &
- & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833, &
- & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833, &
- & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833, &
- & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833, &
- & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833, &
- & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833, &
- & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833, &
- & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833, &
- & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833, &
- & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833, &
- & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833, &
- & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833, &
- & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833, &
- & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, &
- & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, &
- & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, &
- & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, &
- & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 &
- & ], [4, 330])
-END FUNCTION QP_Tetrahedron_Order15
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order16() RESULT(ans)
- REAL(DFP) :: ans(4, 495)
- ans = QP_Tetrahedron_Order17()
-END FUNCTION QP_Tetrahedron_Order16
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order17() RESULT(ans)
- REAL(DFP) :: ans(4, 495)
- ans = RESHAPE([ &
- & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167, &
- & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000, &
- & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000, &
- & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000, &
- & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000, &
- & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000, &
- & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000, &
- & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000, &
- & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000, &
- & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000, &
- & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000, &
- & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000, &
- & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000, &
- & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000, &
- & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000, &
- & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000, &
- & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000, &
- & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000, &
- & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000, &
- & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000, &
- & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000, &
- & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000, &
- & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000, &
- & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000, &
- & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000, &
- & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000, &
- & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000, &
- & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000, &
- & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000, &
- & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000, &
- & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000, &
- & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000, &
- & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000, &
- & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000, &
- & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000, &
- & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000, &
- & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000, &
- & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000, &
- & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000, &
- & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000, &
- & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000, &
- & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000, &
- & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000, &
- & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000, &
- & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000, &
- & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000, &
- & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000, &
- & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000, &
- & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000, &
- & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000, &
- & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000, &
- & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000, &
- & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000, &
- & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000, &
- & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000, &
- & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000, &
- & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000, &
- & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000, &
- & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000, &
- & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000, &
- & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000, &
- & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000, &
- & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000, &
- & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000, &
- & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000, &
- & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000, &
- & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000, &
- & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000, &
- & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000, &
- & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000, &
- & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000, &
- & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000, &
- & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000, &
- & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000, &
- & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000, &
- & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000, &
- & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000, &
- & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000, &
- & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000, &
- & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000, &
- & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333, &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000, &
- & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000, &
- & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000, &
- & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000, &
- & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000, &
- & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000, &
- & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000, &
- & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000, &
- & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000, &
- & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000, &
- & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000, &
- & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000, &
- & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000, &
- & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000, &
- & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000, &
- & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000, &
- & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000, &
- & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000, &
- & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000, &
- & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000, &
- & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000, &
- & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000, &
- & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000, &
- & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000, &
- & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000, &
- & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000, &
- & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000, &
- & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000, &
- & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000, &
- & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000, &
- & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000, &
- & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000, &
- & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000, &
- & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000, &
- & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000, &
- & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000, &
- & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000, &
- & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000, &
- & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000, &
- & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000, &
- & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000, &
- & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000, &
- & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000, &
- & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000, &
- & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000, &
- & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000, &
- & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000, &
- & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000, &
- & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000, &
- & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000, &
- & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000, &
- & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000, &
- & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000, &
- & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333, &
- & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333, &
- & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333, &
- & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333, &
- & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333, &
- & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333, &
- & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333, &
- & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333, &
- & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333, &
- & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333, &
- & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333, &
- & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333, &
- & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333, &
- & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333, &
- & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, &
- & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333, &
- & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333, &
- & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333, &
- & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333, &
- & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333, &
- & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333, &
- & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333, &
- & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333, &
- & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333, &
- & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333, &
- & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333, &
- & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333, &
- & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333, &
- & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333, &
- & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333, &
- & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333, &
- & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333, &
- & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333, &
- & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333, &
- & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, &
- & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, &
- & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, &
- & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, &
- & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3573205875e-08 &
- & ], [4, 495])
-END FUNCTION QP_Tetrahedron_Order17
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order18() RESULT(ans)
- REAL(DFP) :: ans(4, 715)
- ans = QP_Tetrahedron_Order19()
-END FUNCTION QP_Tetrahedron_Order18
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order19() RESULT(ans)
- REAL(DFP) :: ans(4, 715)
- ans = RESHAPE([ &
- & 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333, &
- & 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333, &
- & 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333, &
- & 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333, &
- & 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333, &
- & 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333, &
- & 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333, &
- & 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333, &
- & 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333, &
- & 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333, &
- & 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333, &
- & 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333, &
- & 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333, &
- & 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333, &
- & 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333, &
- & 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333, &
- & 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333, &
- & 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333, &
- & 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333, &
- & 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333, &
- & 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333, &
- & 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333, &
- & 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333, &
- & 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333, &
- & 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333, &
- & 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333, &
- & 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333, &
- & 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333, &
- & 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333, &
- & 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333, &
- & 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333, &
- & 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333, &
- & 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333, &
- & 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333, &
- & 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333, &
- & 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333, &
- & 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333, &
- & 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333, &
- & 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333, &
- & 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333, &
- & 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333, &
- & 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333, &
- & 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333, &
- & 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333, &
- & 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333, &
- & 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333, &
- & 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333, &
- & 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333, &
- & 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333, &
- & 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333, &
- & 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333, &
- & 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333, &
- & 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333, &
- & 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333, &
- & 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333, &
- & 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333, &
- & 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333, &
- & 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333, &
- & 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333, &
- & 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333, &
- & 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333, &
- & 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333, &
- & 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333, &
- & 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333, &
- & 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333, &
- & 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333, &
- & 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333, &
- & 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333, &
- & 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333, &
- & 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333, &
- & 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333, &
- & 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333, &
- & 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333, &
- & 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333, &
- & 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333, &
- & 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333, &
- & 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333, &
- & 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333, &
- & 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333, &
- & 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333, &
- & 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333, &
- & 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333, &
- & 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333, &
- & 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333, &
- & 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333, &
- & 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333, &
- & 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333, &
- & 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333, &
- & 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333, &
- & 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333, &
- & 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333, &
- & 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333, &
- & 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333, &
- & 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333, &
- & 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333, &
- & 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333, &
- & 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333, &
- & 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333, &
- & 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333, &
- & 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333, &
- & 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333, &
- & 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333, &
- & 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333, &
- & 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333, &
- & 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333, &
- & 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333, &
- & 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333, &
- & 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333, &
- & 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333, &
- & 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333, &
- & 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333, &
- & 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333, &
- & 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333, &
- & 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333, &
- & 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333, &
- & 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333, &
- & 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333, &
- & 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333, &
- & 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333, &
- & 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333, &
- & 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333, &
- & 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333, &
- & 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333, &
- & 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333, &
- & 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333, &
- & 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333, &
- & 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333, &
- & 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333, &
- & 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333, &
- & 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333, &
- & 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333, &
- & 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333, &
- & 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333, &
- & 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333, &
- & 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333, &
- & 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333, &
- & 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333, &
- & 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333, &
- & 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333, &
- & 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333, &
- & 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333, &
- & 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333, &
- & 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333, &
- & 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333, &
- & 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333, &
- & 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333, &
- & 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333, &
- & 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667, &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000, &
- & 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000, &
- & 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000, &
- & 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000, &
- & 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000, &
- & 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000, &
- & 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000, &
- & 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000, &
- & 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000, &
- & 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000, &
- & 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000, &
- & 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000, &
- & 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000, &
- & 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000, &
- & 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000, &
- & 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000, &
- & 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000, &
- & 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000, &
- & 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000, &
- & 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000, &
- & 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000, &
- & 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000, &
- & 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000, &
- & 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000, &
- & 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000, &
- & 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000, &
- & 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000, &
- & 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000, &
- & 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000, &
- & 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000, &
- & 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000, &
- & 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000, &
- & 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000, &
- & 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000, &
- & 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000, &
- & 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000, &
- & 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000, &
- & 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000, &
- & 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000, &
- & 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000, &
- & 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000, &
- & 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000, &
- & 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000, &
- & 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000, &
- & 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000, &
- & 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000, &
- & 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000, &
- & 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000, &
- & 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000, &
- & 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000, &
- & 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000, &
- & 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000, &
- & 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000, &
- & 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667, &
- & 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667, &
- & 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667, &
- & 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667, &
- & 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667, &
- & 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667, &
- & 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667, &
- & 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667, &
- & 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667, &
- & 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667, &
- & 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667, &
- & 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667, &
- & 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667, &
- & 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667, &
- & 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, &
- & 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667, &
- & 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667, &
- & 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667, &
- & 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667, &
- & 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667, &
- & 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667, &
- & 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667, &
- & 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667, &
- & 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667, &
- & 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667, &
- & 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667, &
- & 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667, &
- & 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667, &
- & 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667, &
- & 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667, &
- & 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667, &
- & 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667, &
- & 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667, &
- & 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667, &
- & 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, &
- & 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, &
- & 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, &
- & 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, &
- & 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 &
- & ], [4, 715])
-END FUNCTION QP_Tetrahedron_Order19
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order20() RESULT(ans)
- REAL(DFP) :: ans(4, 1001)
- ans = QP_Tetrahedron_Order21()
-END FUNCTION QP_Tetrahedron_Order20
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QP_Tetrahedron_Order21() RESULT(ans)
- REAL(DFP) :: ans(4, 1001)
- ans = RESHAPE([ &
- & 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, &
- & 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, &
- & 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500, &
- & 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500, &
- & 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500, &
- & 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667, &
- & 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667, &
- & 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667, &
- & 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667, &
- & 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667, &
- & 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667, &
- & 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667, &
- & 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667, &
- & 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667, &
- & 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667, &
- & 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667, &
- & 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667, &
- & 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667, &
- & 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667, &
- & 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667, &
- & 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667, &
- & 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667, &
- & 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667, &
- & 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667, &
- & 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667, &
- & 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667, &
- & 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667, &
- & 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667, &
- & 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667, &
- & 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667, &
- & 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667, &
- & 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667, &
- & 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667, &
- & 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667, &
- & 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667, &
- & 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667, &
- & 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667, &
- & 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667, &
- & 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667, &
- & 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667, &
- & 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667, &
- & 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667, &
- & 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667, &
- & 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667, &
- & 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667, &
- & 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667, &
- & 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667, &
- & 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667, &
- & 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667, &
- & 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667, &
- & 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667, &
- & 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667, &
- & 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667, &
- & 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667, &
- & 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667, &
- & 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667, &
- & 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667, &
- & 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667, &
- & 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667, &
- & 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667, &
- & 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667, &
- & 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667, &
- & 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667, &
- & 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667, &
- & 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667, &
- & 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667, &
- & 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667, &
- & 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667, &
- & 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667, &
- & 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667, &
- & 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667, &
- & 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667, &
- & 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000, &
- & 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000, &
- & 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000, &
- & 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000, &
- & 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000, &
- & 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000, &
- & 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000, &
- & 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000, &
- & 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000, &
- & 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000, &
- & 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000, &
- & 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000, &
- & 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000, &
- & 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000, &
- & 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000, &
- & 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000, &
- & 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000, &
- & 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000, &
- & 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000, &
- & 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000, &
- & 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000, &
- & 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000, &
- & 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000, &
- & 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000, &
- & 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000, &
- & 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000, &
- & 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000, &
- & 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000, &
- & 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000, &
- & 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000, &
- & 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000, &
- & 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000, &
- & 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000, &
- & 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000, &
- & 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000, &
- & 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000, &
- & 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000, &
- & 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000, &
- & 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000, &
- & 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000, &
- & 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000, &
- & 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000, &
- & 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000, &
- & 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000, &
- & 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000, &
- & 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000, &
- & 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000, &
- & 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000, &
- & 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000, &
- & 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000, &
- & 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000, &
- & 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000, &
- & 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000, &
- & 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000, &
- & 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000, &
- & 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000, &
- & 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000, &
- & 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000, &
- & 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000, &
- & 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000, &
- & 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000, &
- & 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000, &
- & 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000, &
- & 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000, &
- & 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000, &
- & 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000, &
- & 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000, &
- & 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000, &
- & 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000, &
- & 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000, &
- & 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000, &
- & 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000, &
- & 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000, &
- & 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000, &
- & 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000, &
- & 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000, &
- & 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000, &
- & 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000, &
- & 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000, &
- & 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000, &
- & 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000, &
- & 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333, &
- & 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333, &
- & 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333, &
- & 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333, &
- & 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333, &
- & 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333, &
- & 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333, &
- & 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333, &
- & 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333, &
- & 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333, &
- & 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333, &
- & 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333, &
- & 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333, &
- & 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333, &
- & 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333, &
- & 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333, &
- & 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333, &
- & 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333, &
- & 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333, &
- & 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333, &
- & 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333, &
- & 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333, &
- & 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333, &
- & 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333, &
- & 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333, &
- & 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333, &
- & 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333, &
- & 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333, &
- & 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333, &
- & 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333, &
- & 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333, &
- & 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333, &
- & 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333, &
- & 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333, &
- & 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333, &
- & 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333, &
- & 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333, &
- & 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333, &
- & 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333, &
- & 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333, &
- & 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333, &
- & 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333, &
- & 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333, &
- & 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333, &
- & 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333, &
- & 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333, &
- & 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333, &
- & 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333, &
- & 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333, &
- & 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333, &
- & 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333, &
- & 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333, &
- & 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333, &
- & 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333, &
- & 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333, &
- & 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333, &
- & 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550, &
- & 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550, &
- & 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550, &
- & 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550, &
- & 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550, &
- & 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550, &
- & 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550, &
- & 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550, &
- & 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550, &
- & 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550, &
- & 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550, &
- & 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550, &
- & 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550, &
- & 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550, &
- & 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, &
- & 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550, &
- & 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550, &
- & 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550, &
- & 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550, &
- & 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550, &
- & 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550, &
- & 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550, &
- & 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550, &
- & 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550, &
- & 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550, &
- & 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550, &
- & 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550, &
- & 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550, &
- & 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550, &
- & 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550, &
- & 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550, &
- & 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550, &
- & 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550, &
- & 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550, &
- & 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, &
- & 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, &
- & 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, &
- & 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, &
- & 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878, &
- & 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05, &
- & 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05, &
- & 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05, &
- & 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, &
- & 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, &
- & 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, &
- & 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05, &
- & 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05, &
- & 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, &
- & 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05, &
- & 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08, &
- & 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08, &
- & 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, &
- & 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08, &
- & 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 &
- & ], [4, 1001])
-END FUNCTION QP_Tetrahedron_Order21
-
-!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
END MODULE QuadraturePoint_Tetrahedron_Solin
diff --git a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90 b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90
index cb6c67770..c27db2507 100644
--- a/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/RecursiveNodesUtility@Methods.F90
@@ -16,76 +16,173 @@
!
SUBMODULE(RecursiveNodesUtility) Methods
-USE BaseMethod
+USE StringUtility, ONLY: UpperCase
+
+USE IntegerUtility, ONLY: GetMultiIndices_, Size
+
+USE PushPopUtility, ONLY: Pop, Push
+
+USE LineInterpolationUtility, ONLY: InterpolationPoint_Line_
+
CONTAINS
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+FUNCTION NumberofRows(d, domain) RESULT(nrow)
+ INTEGER(I4B), INTENT(IN) :: d
+ CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: domain
+ INTEGER(I4B) :: nrow
+
+ LOGICAL(LGT) :: isdomain
+ CHARACTER(2) :: mydomain
+
+ isdomain = PRESENT(domain)
+ mydomain = "BA"
+ IF (isdomain) mydomain = UpperCase(domain(1:2))
+
+ IF (mydomain .EQ. "BA") THEN
+ nrow = d + 1
+ ELSE
+ nrow = d
+ END IF
+END FUNCTION NumberofRows
+
!----------------------------------------------------------------------------
! 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, &
- & layout="INCREASING", &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-
-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
+INTEGER(I4B) :: nrow, ncol
-IF (PRESENT(domain)) THEN
- ans = Coord_Map(x=ans, from="BaryCentric", to=domain)
-END IF
+nrow = NumberofRows(d=1_I4B, domain=domain)
+ncol = SIZE(n=order, d=1_I4B)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL RecursiveNode1D_(order=order, ipType=ipType, ans=ans, nrow=nrow, &
+ ncol=ncol, alpha=alpha, beta=beta, lambda=lambda, domain=domain)
-IF (ALLOCATED(indices)) DEALLOCATE (indices)
-IF (ALLOCATED(x)) DEALLOCATE (x)
END PROCEDURE RecursiveNode1D
+!----------------------------------------------------------------------------
+! RecursiveNode1D
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RecursiveNode1D_
+INTEGER(I4B), PARAMETER :: d = 1_I4B, max_order = 99_I4B
+INTEGER(I4B) :: jj, tsize, i1, i2, aint, bint
+REAL(DFP) :: avar, x(max_order + 1), xij(2, 1)
+LOGICAL(LGT) :: isdomain
+CHARACTER(2) :: mydomain
+
+INTEGER(I4B), ALLOCATABLE :: indices(:, :)
+
+isdomain = PRESENT(domain)
+mydomain = "BA"
+IF (isdomain) mydomain = domain(1:2)
+
+xij(1, 1) = 0.0_DFP
+xij(2, 1) = 1.0_DFP
+
+CALL InterpolationPoint_Line_(order=order, ipType=ipType, xij=xij(:, 1), &
+ ans=x, layout="INCREASING", alpha=alpha, beta=beta, lambda=lambda, &
+ tsize=tsize)
+
+nrow = d + 1
+ncol = SIZE(n=order, d=d)
+
+ALLOCATE (indices(nrow, ncol))
+
+CALL GetMultiIndices_(n=order, d=d, ans=indices, nrow=nrow, ncol=ncol)
+
+SELECT CASE (mydomain)
+CASE ("BA", "Ba", "ba")
+ DO jj = 1, ncol
+ i1 = indices(1, jj) + 1
+ i2 = indices(2, jj) + 1
+
+ avar = x(i1) + x(i2)
+
+ ans(1, jj) = x(i1) / avar
+ ans(2, jj) = x(i2) / avar
+ END DO
+
+CASE default
+ nrow = nrow - 1
+
+ DO jj = 1, ncol
+ i1 = indices(1, jj) + 1
+ i2 = indices(2, jj) + 1
+
+ avar = x(i1) + x(i2)
+
+ xij(1, 1) = x(i1) / avar
+ xij(2, 1) = x(i2) / avar
+
+ CALL Coord_Map_(x=xij, from="BARYCENTRIC", to=mydomain, &
+ ans=ans(:, jj:), nrow=aint, ncol=bint)
+ END DO
+
+END SELECT
+
+DEALLOCATE (indices)
+
+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) :: nrow, ncol
+nrow = NumberofRows(d=2_I4B, domain=domain)
+ncol = SIZE(n=order, d=2_I4B)
+ALLOCATE (ans(nrow, ncol))
+CALL RecursiveNode2D_(order=order, iptype=iptype, ans=ans, nrow=nrow, &
+ ncol=ncol, domain=domain, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE RecursiveNode2D
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RecursiveNode2D_
+INTEGER(I4B), PARAMETER :: d = 2_I4B, dp1 = 3_I4B
+INTEGER(I4B), PARAMETER :: max_order = 100 !! max_order + 1
+
+INTEGER(I4B) :: aindx(dp1), indx(d), aint, bint, jj, ii
+
+REAL(DFP) :: xi, xt, b(dp1), bs(d), Xn(max_order), &
+ BX(d, max_order, max_order), xij(dp1, 1), &
+ bxn(d, max_order)
+
INTEGER(I4B), ALLOCATABLE :: indices(:, :)
-n = order
-CALL BarycentericNodeFamily1D( &
- & order=order, &
- & ipType=ipType, &
- & ans=BX, &
- & Xn=Xn, &
- & alpha=alpha, beta=beta, lambda=lambda)
+CHARACTER(2) :: mydomain
+LOGICAL(LGT) :: isdomain
+
+isdomain = PRESENT(domain)
+mydomain = "BA"; IF (isdomain) mydomain = UpperCase(domain(1:2))
+
+nrow = d + 1
+ncol = SIZE(n=order, d=d)
+ALLOCATE (indices(nrow, ncol))
+
+CALL BarycentericNodeFamily1D(order=order, ipType=ipType, ans=BX, &
+ Xn=Xn, alpha=alpha, beta=beta, lambda=lambda, &
+ indices=indices, bxn=bxn)
+
+CALL GetMultiIndices_(n=order, d=d, ans=indices, nrow=nrow, ncol=ncol)
-indices = GetMultiIndices(n=n, d=d)
-CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2))
+IF (mydomain .NE. "BA") nrow = d
-DO jj = 1, SIZE(ans, 2)
+DO jj = 1, ncol
aindx = indices(:, jj)
+
xt = 0.0_DFP
+ xij = 0.0_DFP
DO ii = 1, d + 1
indx = Pop(aindx, ii)
@@ -93,158 +190,183 @@
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
+ xij(:, 1) = xij(:, 1) + 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
+ xij = xij / xt
+
+ CALL Coord_Map_(x=xij, from="BARYCENTRIC", to=mydomain, &
+ ans=ans(:, jj:), nrow=aint, ncol=bint)
+
+END DO
IF (ALLOCATED(indices)) DEALLOCATE (indices)
-END PROCEDURE RecursiveNode2D
+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) :: nrow, ncol
+nrow = NumberofRows(d=3_I4B, domain=domain)
+ncol = SIZE(n=order, d=3_I4B)
+ALLOCATE (ans(nrow, ncol))
+CALL RecursiveNode3D_(order=order, iptype=iptype, ans=ans, nrow=nrow, &
+ ncol=ncol, domain=domain, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE RecursiveNode3D
+
+!----------------------------------------------------------------------------
+! RecursiveNode3D_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RecursiveNode3D_
+INTEGER(I4B), PARAMETER :: d = 3_I4B, dp1 = 4_I4B, max_order = 26
+
+INTEGER(I4B) :: jj, ii, aint, bint, aindx(dp1), indx(d)
+
+REAL(DFP) :: xi, xt, b(dp1), bs(d), xn(max_order), &
+ bx(d, max_order, max_order, max_order), xij(dp1, 1)
+
INTEGER(I4B), ALLOCATABLE :: indices(:, :)
+REAL(DFP), ALLOCATABLE :: bxn(:, :)
+
+CHARACTER(2) :: mydomain
+LOGICAL(LGT) :: isdomain
+
+isdomain = PRESENT(domain)
+mydomain = "BA"; IF (isdomain) mydomain = UpperCase(domain(1:2))
+
+nrow = d + 1
+ncol = SIZE(n=order, d=d)
+ALLOCATE (indices(nrow, ncol), bxn(d, ncol))
-n = order
-CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=BX, Xn=Xn, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+CALL BarycentericNodeFamily2D(order=order, ipType=ipType, ans=bx, Xn=Xn, &
+ alpha=alpha, beta=beta, lambda=lambda, indices=indices, bxn=bxn)
-indices = GetMultiIndices(n=n, d=d)
-CALL Reallocate(ans, SIZE(indices, 1), SIZE(indices, 2))
-ans = 0.0_DFP
+CALL GetMultiIndices_(n=order, d=d, ans=indices, nrow=nrow, ncol=ncol)
-DO jj = 1, SIZE(ans, 2)
+IF (mydomain .NE. "BA") nrow = d
+
+DO jj = 1, ncol
aindx = indices(:, jj)
xt = 0.0_DFP
+ xij = 0.0_DFP
- DO ii = 1, d + 1
+ DO ii = 1, dp1
indx = Pop(aindx, ii)
- bs = BX(:, indx(1) + 1, indx(2) + 1, indx(3) + 1)
+ 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)
+ xi = xn(SUM(indx) + 1)
xt = xt + xi
- ans(:, jj) = ans(:, jj) + xi * b
+ xij(:, 1) = xij(:, 1) + xi * b
END DO
- ans(:, jj) = ans(:, jj) / xt
+ xij = xij / xt
-END DO
+ CALL Coord_Map_(x=xij, from="BARYCENTRIC", to=mydomain, &
+ ans=ans(:, jj:), nrow=aint, ncol=bint)
-IF (PRESENT(domain)) THEN
- ans = Coord_Map(x=ans, from="BaryCentric", to=domain)
-END IF
+END DO
IF (ALLOCATED(indices)) DEALLOCATE (indices)
+IF (ALLOCATED(bxn)) DEALLOCATE (bxn)
-END PROCEDURE RecursiveNode3D
+END PROCEDURE RecursiveNode3D_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn, alpha, &
- & beta, lambda)
+SUBROUTINE BarycentericNodeFamily1D(order, ipType, ans, Xn, indices, bxn, &
+ alpha, beta, lambda)
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)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! ans(2, order + 1, order + 1)
+ REAL(DFP), INTENT(INOUT) :: Xn(:)
+ !! Xn(order + 1)
+ INTEGER(I4B), INTENT(INOUT) :: indices(:, :)
+ !!
+ REAL(DFP), INTENT(INOUT) :: bxn(:, :)
+ !!
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
- !! Ultraspherical polynomial parameter
- !
- INTEGER(I4B) :: ii, jj, n
- INTEGER(I4B), PARAMETER :: d = 1_I4B
- REAL(DFP), ALLOCATABLE :: BXn(:, :)
- INTEGER(I4B), ALLOCATABLE :: indices(:, :)
- !!
+ !! Ultraspherical polynomial parameter
+
+ INTEGER(I4B), PARAMETER :: d = 1_I4B, dp1 = 2_I4B
+ INTEGER(I4B) :: ii, jj, nrow, ncol
+
DO ii = 0, order
- n = ii
- indices = GetMultiIndices(n=n, d=d)
- BXn = RecursiveNode1D(order=n, ipType=ipType, &
- & alpha=alpha, beta=beta, lambda=lambda)
- !!
- DO jj = 1, n + 1
- ans(1:d + 1, indices(1, jj) + 1, indices(2, jj) + 1) = BXn(1:d + 1, jj)
+ ! indices = GetMultiIndices(n=ii, d=d)
+ CALL GetMultiIndices_(n=ii, d=d, ans=indices, nrow=nrow, ncol=ncol)
+
+ CALL RecursiveNode1D_(order=ii, ipType=ipType, ans=bxn, nrow=nrow, &
+ ncol=ncol, alpha=alpha, beta=beta, lambda=lambda)
+
+ DO jj = 1, ii + 1
+ ans(1:dp1, indices(1, jj) + 1, indices(2, jj) + 1) = bxn(1:dp1, jj)
END DO
- !!
+
END DO
- !!
- Xn = BXn(1, :)
- !!
- IF (ALLOCATED(BXn)) DEALLOCATE (BXn)
- IF (ALLOCATED(indices)) DEALLOCATE (indices)
- !!
+
+ Xn(1:order + 1) = bxn(1, 1:order + 1)
+
END SUBROUTINE BarycentericNodeFamily1D
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn, alpha, beta, lambda)
+SUBROUTINE BarycentericNodeFamily2D(order, ipType, ans, Xn, alpha, beta, &
+ lambda, indices, bxn)
+
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)
+ REAL(DFP), INTENT(inout) :: ans(:, :, :, :)
+ !! ans(3, order + 1, order + 1, order + 1)
+ REAL(DFP), INTENT(OUT) :: xn(:)
+ !! Xn(order + 1)
+ INTEGER(I4B), INTENT(INOUT) :: indices(:, :)
+ !!
+ REAL(DFP), INTENT(INOUT) :: bxn(:, :)
+ !!
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta
- !! Jacobi polynomial parameter
+ !! Jacobi polynomial parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda
- !! Ultraspherical polynomial parameter
- !!
- INTEGER(I4B) :: ii, jj, n
- INTEGER(I4B), PARAMETER :: d = 2_I4B
- REAL(DFP), ALLOCATABLE :: BXn(:, :)
- INTEGER(I4B), ALLOCATABLE :: indices(:, :)
- REAL(DFP) :: avar
+ !! Ultraspherical polynomial parameter
+
+ !! Internal varible
+
REAL(DFP), PARAMETER :: xij(2) = [0.0_DFP, 1.0_DFP]
- !!
+ INTEGER(I4B), PARAMETER :: d = 2_I4B
+ INTEGER(I4B) :: ii, jj, nrow, ncol
+
DO ii = 0, order
- n = ii
- indices = GetMultiIndices(n=n, d=d)
- BXn = RecursiveNode2D(order=n, ipType=ipType, alpha=alpha, beta=beta, lambda=lambda )
- !!
- 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)
+ CALL GetMultiIndices_(n=ii, d=d, ans=indices, nrow=nrow, ncol=ncol)
+
+ CALL RecursiveNode2D_(order=ii, ipType=ipType, alpha=alpha, &
+ beta=beta, lambda=lambda, ans=bxn, nrow=nrow, ncol=ncol)
+
+ DO jj = 1, ncol
+ 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, &
- & layout="INCREASING", alpha=alpha, beta=beta, lambda=lambda)
- !!
- ! 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)
- !!
+
+ CALL InterpolationPoint_Line_(ans=xn, tsize=nrow, order=order, &
+ ipType=ipType, xij=xij, layout="INCREASING", alpha=alpha, &
+ beta=beta, lambda=lambda)
+
END SUBROUTINE BarycentericNodeFamily2D
!----------------------------------------------------------------------------
@@ -253,7 +375,7 @@ END SUBROUTINE BarycentericNodeFamily2D
MODULE PROCEDURE Unit2Equilateral
INTEGER(I4B) :: ii
-!!
+
IF (d .GT. 1_I4B) THEN
! Move the top vertex over the centroid
DO ii = 1, d - 1
@@ -272,7 +394,7 @@ END SUBROUTINE BarycentericNodeFamily2D
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, :))
@@ -287,50 +409,92 @@ END SUBROUTINE BarycentericNodeFamily2D
!----------------------------------------------------------------------------
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
+INTEGER(I4B) :: nrow, ncol
+CHARACTER(2) :: mydomain
+mydomain = UpperCase(domain(1:2))
+nrow = SIZE(x, 1)
+ncol = SIZE(x, 2)
+IF (mydomain .EQ. "BA") nrow = nrow - 1
+ALLOCATE (ans(nrow, ncol))
+CALL ToUnit_(x=x, domain=mydomain, ans=ans, nrow=nrow, ncol=ncol)
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
+MODULE PROCEDURE ToUnit_
+nrow = SIZE(x, 1)
+ncol = SIZE(x, 2)
+
+SELECT CASE (domain(1:2))
+CASE ("UN", "un", "Un")
+ ans(1:nrow, 1:ncol) = x
+
+CASE ("BI", "bi", "Bi")
+ ans(1:nrow, 1:ncol) = 0.5_DFP * (x + 1.0_DFP)
+
+CASE ("BA", "ba", "Ba")
+ nrow = nrow - 1
+ ans(1:nrow, 1:ncol) = x(1:nrow, :)
+
+CASE ("EQ", "eq", "Eq")
+ ans(1:nrow, 1:ncol) = x
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) * 0.5_DFP
+
+ CALL Equilateral2Unit(d=nrow, x=ans)
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + 1.0_DFP / &
+ (REAL(nrow, kind=dfp) + 1.0_DFP)
+
END SELECT
+END PROCEDURE ToUnit_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnit
+INTEGER(I4B) :: nrow, ncol
+CHARACTER(2) :: mydomain
+mydomain = UpperCase(domain(1:2))
+nrow = SIZE(x, 1)
+ncol = SIZE(x, 2)
+IF (mydomain .EQ. "BA") nrow = nrow + 1
+CALL FromUnit_(x=x, domain=mydomain, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE FromUnit
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnit_
+nrow = SIZE(x, 1)
+ncol = SIZE(x, 2)
+
+SELECT CASE (domain(1:2))
+CASE ("UN", "Un", "un")
+ ans(1:nrow, 1:ncol) = x
+
+CASE ("BI", "Bi", "bi")
+ ans(1:nrow, 1:ncol) = 2.0_DFP * x - 1.0_DFP
+
+CASE ("BA", "Ba", "ba")
+ ans(1:nrow, 1:ncol) = x
+ nrow = nrow + 1
+ ans(nrow, 1:ncol) = (1.0_DFP - SUM(x, dim=1))
+
+CASE ("EQ", "Eq", "eq")
+ ans(1:nrow, 1:ncol) = x - 1.0_DFP / (REAL(nrow, kind=DFP) + 1.0_DFP)
+
+ CALL Unit2Equilateral(d=nrow, x=ans)
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) * 2.0_DFP
+
+END SELECT
+END PROCEDURE FromUnit_
+
!----------------------------------------------------------------------------
! Coord_Map
!----------------------------------------------------------------------------
@@ -339,6 +503,17 @@ END SUBROUTINE BarycentericNodeFamily2D
ans = FromUnit(x=(ToUnit(x=x, domain=from)), domain=to)
END PROCEDURE Coord_Map
+!----------------------------------------------------------------------------
+! Coord_Map
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Coord_Map_
+INTEGER(I4B) :: aint, bint
+CALL ToUnit_(x=x, domain=from, ans=ans, nrow=aint, ncol=bint)
+CALL FromUnit_(x=ans(1:aint, 1:bint), domain=to, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE Coord_Map_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90
index 0c0fcc3b2..fc5d4241e 100644
--- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90
@@ -16,12 +16,14 @@
SUBMODULE(TetrahedronInterpolationUtility) Methods
USE BaseMethod
-USE QuadraturePoint_Tetrahedron_Solin, ONLY: &
-& QuadratureNumberTetrahedronSolin, &
-& QuadratureOrderTetrahedronSolin, &
-& QuadraturePointTetrahedronSolin, &
-& MAX_ORDER_TETRAHEDRON_SOLIN
+USE QuadraturePoint_Tetrahedron_Solin, ONLY: &
+ QuadratureNumberTetrahedronSolin, &
+ QuadratureOrderTetrahedronSolin, &
+ QuadraturePointTetrahedronSolin, &
+ MAX_ORDER_TETRAHEDRON_SOLIN
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -95,10 +97,10 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE GetFacetDOF_Tetrahedron1
-ans = (ps1 - 1) * (ps1 - 2) / 2 &
- & + (ps2 - 1) * (ps2 - 2) / 2 &
- & + (ps3 - 1) * (ps3 - 2) / 2 &
- & + (ps4 - 1) * (ps4 - 2) / 2
+ans = (ps1 - 1) * (ps1 - 2) / 2 &
+ + (ps2 - 1) * (ps2 - 2) / 2 &
+ + (ps3 - 1) * (ps3 - 2) / 2 &
+ + (ps4 - 1) * (ps4 - 2) / 2
END PROCEDURE GetFacetDOF_Tetrahedron1
!----------------------------------------------------------------------------
@@ -143,15 +145,15 @@
SELECT CASE (baseInterpol0%chars())
CASE ( &
- & "HIERARCHYPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHYPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION", &
- & "ORTHOGONALPOLYNOMIAL", &
- & "ORTHOGONAL", &
- & "ORTHOGONALINTERPOLATION")
+ "HIERARCHYPOLYNOMIAL", &
+ "HIERARCHY", &
+ "HEIRARCHYPOLYNOMIAL", &
+ "HEIRARCHY", &
+ "HIERARCHYINTERPOLATION", &
+ "HEIRARCHYINTERPOLATION", &
+ "ORTHOGONALPOLYNOMIAL", &
+ "ORTHOGONAL", &
+ "ORTHOGONALINTERPOLATION")
ans(:, 1) = [1, 2, 3]
ans(:, 2) = [1, 2, 4]
ans(:, 3) = [1, 3, 4]
@@ -170,9 +172,23 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeDegree_Tetrahedron
-INTEGER(I4B) :: n, ii, jj, kk, ll
-n = LagrangeDOF_Tetrahedron(order=order)
-ALLOCATE (ans(n, 3))
+INTEGER(I4B) :: nrow, ncol
+nrow = LagrangeDOF_Tetrahedron(order=order)
+ncol = 3
+ALLOCATE (ans(nrow, ncol))
+CALL LagrangeDegree_Tetrahedron_(order=order, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE LagrangeDegree_Tetrahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Tetrahedron_
+INTEGER(I4B) :: ii, jj, kk, ll
+
+nrow = LagrangeDOF_Tetrahedron(order=order)
+ncol = 3
+
ll = 0
DO kk = 0, order
DO jj = 0, order
@@ -186,7 +202,8 @@
END DO
END DO
END DO
-END PROCEDURE LagrangeDegree_Tetrahedron
+
+END PROCEDURE LagrangeDegree_Tetrahedron_
!----------------------------------------------------------------------------
! LagrangeDOF_Tetrahedron
@@ -433,14 +450,22 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Tetrahedron
-ans = InterpolationPoint_Tetrahedron( &
- & order=order, &
- & ipType=Equidistance, &
- & layout="VEFC", &
- & xij=xij &
- &)
+INTEGER(I4B) :: nrow, ncol
+ncol = SIZE(n=order, d=3)
+ALLOCATE (ans(3, ncol))
+CALL EquidistancePoint_Tetrahedron_(order=order, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
END PROCEDURE EquidistancePoint_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Tetrahedron_
+CALL InterpolationPoint_Tetrahedron_(order=order, ipType=Equidistance, &
+ layout="VEFC", xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE EquidistancePoint_Tetrahedron_
+
!----------------------------------------------------------------------------
! EquidistanceInPoint_Tetrahedron
!----------------------------------------------------------------------------
@@ -461,28 +486,31 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE InterpolationPoint_Tetrahedron
-ans = Isaac_Tetrahedron( &
- & order=order, &
- & ipType=ipType, &
- & layout=layout, &
- & xij=xij, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+INTEGER(I4B) :: nrow, ncol
+ncol = SIZE(n=order, d=3)
+ALLOCATE (ans(3, ncol))
+CALL InterpolationPoint_Tetrahedron_(order=order, ipType=ipType, &
+ layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE InterpolationPoint_Tetrahedron
+!----------------------------------------------------------------------------
+! InterpolationPoint_Tetrahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Tetrahedron_
+CALL Isaac_Tetrahedron(order=order, ipType=ipType, layout=layout, xij=xij, &
+ alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Tetrahedron1_(order=order, i=i, xij=xij, ans=ans, &
+ tsize=tsize)
END PROCEDURE LagrangeCoeff_Tetrahedron1
!----------------------------------------------------------------------------
@@ -490,12 +518,9 @@
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Tetrahedron2_(order=order, i=i, v=v, &
+ isVandermonde=.TRUE., ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Tetrahedron2
!----------------------------------------------------------------------------
@@ -503,9 +528,9 @@
!----------------------------------------------------------------------------
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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Tetrahedron3_(order=order, i=i, v=v, ipiv=ipiv, &
+ ans=ans, tsize=tsize)
END PROCEDURE LagrangeCoeff_Tetrahedron3
!----------------------------------------------------------------------------
@@ -513,68 +538,118 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Tetrahedron4
+INTEGER(I4B) :: nrow, ncol
+
+CALL LagrangeCoeff_Tetrahedron4_(order=order, xij=xij, basisType=basisType, &
+ refTetrahedron=refTetrahedron, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+END PROCEDURE LagrangeCoeff_Tetrahedron4
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Tetrahedron1_
+REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
+INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
+INTEGER(I4B) :: info, nrow, ncol
+
+tsize = SIZE(xij, 2)
+
+ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Tetrahedron, &
+ ans=V, nrow=nrow, ncol=ncol)
+
+CALL GetLU(A=V, IPIV=ipiv, info=info)
+
+CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Tetrahedron1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Tetrahedron2_
+REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp
+INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+
+vtemp = v; ans(1:tsize) = 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(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Tetrahedron2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Tetrahedron3_
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Tetrahedron3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Tetrahedron4_
INTEGER(I4B) :: basisType0
+CHARACTER(:), ALLOCATABLE :: aname
+
basisType0 = input(default=Monomial, option=basisType)
+nrow = SIZE(xij, 2)
+ncol = nrow
SELECT CASE (basisType0)
CASE (Monomial)
- ans = LagrangeVandermonde(order=order, xij=xij, elemType=Tetrahedron)
+ CALL LagrangeVandermonde_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol, elemType=Tetrahedron)
+
CASE (Heirarchical)
- IF (PRESENT(refTetrahedron)) THEN
- ans = HeirarchicalBasis_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & refTetrahedron=refTetrahedron &
- & )
- ELSE
- ans = HeirarchicalBasis_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & refTetrahedron="UNIT" &
- & )
- END IF
+ aname = Input(default="UNIT", option=refTetrahedron)
+
+ ans(1:nrow, 1:ncol) = HeirarchicalBasis_Tetrahedron(order=order, xij=xij, &
+ refTetrahedron=aname)
+
CASE DEFAULT
- IF (PRESENT(refTetrahedron)) THEN
- ans = OrthogonalBasis_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & refTetrahedron=refTetrahedron &
- & )
- ELSE
- ans = OrthogonalBasis_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & refTetrahedron="UNIT" &
- & )
- END IF
+ aname = Input(default="UNIT", option=refTetrahedron)
+
+ ans(1:nrow, 1:ncol) = OrthogonalBasis_Tetrahedron(order=order, &
+ xij=xij, refTetrahedron=refTetrahedron)
+
END SELECT
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Tetrahedron4
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+
+END PROCEDURE LagrangeCoeff_Tetrahedron4_
!----------------------------------------------------------------------------
! Isaac_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE Isaac_Tetrahedron
+! CHARACTER(*), PARAMETER :: myName = "Isaac_Tetrahedron"
+
REAL(DFP), DIMENSION(order + 1, order + 1, order + 1) :: xi, eta, zeta
-REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :)
-INTEGER(I4B) :: nsd, N, cnt, ii, jj, kk
-CHARACTER(*), PARAMETER :: myName = "Isaac_Tetrahedron"
-rPoints = RecursiveNode3D( &
- & order=order, &
- & ipType=ipType, &
- & domain="UNIT", &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+INTEGER(I4B) :: cnt, ii, jj, kk
+
+ncol = SIZE(n=order, d=3)
+nrow = 3
-N = SIZE(rPoints, 2)
+CALL RecursiveNode3D_(order=order, ipType=ipType, domain="UNIT", &
+ alpha=alpha, beta=beta, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
-nsd = 3
-CALL Reallocate(ans, nsd, N)
-CALL Reallocate(temp, nsd, N)
+! CALL Reallocate(ans, nsd, N)
+! CALL Reallocate(temp, nrow, ncol)
!! convert from rPoints to xi and eta
cnt = 0
@@ -587,39 +662,26 @@
DO kk = 0, order
IF (ii + jj + kk .LE. order) THEN
cnt = cnt + 1
- xi(ii + 1, jj + 1, kk + 1) = rPoints(1, cnt)
- eta(ii + 1, jj + 1, kk + 1) = rPoints(2, cnt)
- zeta(ii + 1, jj + 1, kk + 1) = rPoints(3, cnt)
+ xi(ii + 1, jj + 1, kk + 1) = ans(1, cnt)
+ eta(ii + 1, jj + 1, kk + 1) = ans(2, cnt)
+ zeta(ii + 1, jj + 1, kk + 1) = ans(3, cnt)
END IF
END DO
END DO
END DO
IF (layout .EQ. "VEFC") THEN
- CALL IJK2VEFC_Tetrahedron( &
- & xi=xi, &
- & eta=eta, &
- & zeta=zeta, &
- & temp=temp, &
- & order=order, &
- & N=N)
-ELSE
- temp = rPoints
+ CALL IJK2VEFC_Tetrahedron(xi=xi, eta=eta, zeta=zeta, temp=ans, &
+ order=order, N=ncol)
END IF
IF (PRESENT(xij)) THEN
- ans = FromUnitTetrahedron2Tetrahedron( &
- & xin=temp, &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4))
-ELSE
- ans = temp
+ ! convert temp to ans using xij
+ CALL FromUnitTetrahedron2Tetrahedron_(xin=ans(1:nrow, 1:ncol), &
+ x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, &
+ nrow=nrow, ncol=ncol)
END IF
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
-IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints)
END PROCEDURE Isaac_Tetrahedron
!----------------------------------------------------------------------------
@@ -642,21 +704,33 @@
MODULE PROCEDURE IJK2VEFC_Tetrahedron
INTEGER(I4B) :: indof, ii, cnt, jj, kk, ll
+REAL(DFP) :: x(3)
+INTEGER(I4B), PARAMETER :: nrow = 3
+
REAL(DFP), DIMENSION(3, (order + 1)*(order + 2)/2) :: temp_face_in
REAL(DFP), DIMENSION(order + 1, order + 1) :: xi2, eta2, zeta2
SELECT CASE (order)
CASE (0)
- temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
+ x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
+ temp(1:nrow, 1) = x
CASE (1)
! | 0 | 0 | 0 |
! | 0 | 0 | 1 |
! | 0 | 1 | 0 |
! | 1 | 0 | 0 |
- temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
- temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)]
- temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)]
- temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)]
+ x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
+ temp(1:nrow, 1) = x
+
+ x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)]
+ temp(1:nrow, 2) = x
+
+ x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)]
+ temp(1:nrow, 3) = x
+
+ x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)]
+ temp(1:nrow, 4) = x
+
CASE (2)
! | 0 | 0 | 0 |
! | 0 | 0 | 0.5 |
@@ -670,23 +744,41 @@
! | 1 | 0 | 0 |
! four vertex
- temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
- temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)]
- temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)]
- temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)]
+ x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
+ temp(1:nrow, 1) = x
+
+ x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)]
+ temp(1:nrow, 2) = x
+
+ x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)]
+ temp(1:nrow, 3) = x
+
+ x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)]
+ temp(1:nrow, 4) = x
! edge1 x
- temp(:, 5) = [xi(2, 1, 1), eta(2, 1, 1), zeta(2, 1, 1)]
+ x = [xi(2, 1, 1), eta(2, 1, 1), zeta(2, 1, 1)]
+ temp(1:nrow, 5) = x
+
! edge2 y
- temp(:, 6) = [xi(1, 2, 1), eta(1, 2, 1), zeta(1, 2, 1)]
+ x = [xi(1, 2, 1), eta(1, 2, 1), zeta(1, 2, 1)]
+ temp(1:nrow, 6) = x
+
! edge3 z
- temp(:, 7) = [xi(1, 1, 2), eta(1, 1, 2), zeta(1, 1, 2)]
+ x = [xi(1, 1, 2), eta(1, 1, 2), zeta(1, 1, 2)]
+ temp(1:nrow, 7) = x
+
! edge4 xy
- temp(:, 8) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)]
+ x = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)]
+ temp(1:nrow, 8) = x
+
! edge5, xz
- temp(:, 9) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)]
+ x = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)]
+ temp(1:nrow, 9) = x
+
! edge6, yz
- temp(:, 10) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)]
+ x = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)]
+ temp(1:nrow, 10) = x
CASE (3)
! | 0 | 0 | 0 |
@@ -711,149 +803,179 @@
! | 1 | 0 | 0 |
! four vertex
- temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
- temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)]
- temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)]
- temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)]
+ x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
+ temp(1:nrow, 1) = x
+
+ x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)]
+ temp(1:nrow, 2) = x
+
+ x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)]
+ temp(1:nrow, 3) = x
+
+ x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)]
+ temp(1:nrow, 4) = x
cnt = 4
! edge1 x
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)]
+ x = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)]
+ temp(1:nrow, cnt) = x
END DO
+
! edge2 y
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)]
+ x = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)]
+ temp(1:nrow, cnt) = x
END DO
+
! edge3 z
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)]
+ x = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)]
+ temp(1:nrow, cnt) = x
END DO
+
! edge4 xy
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(4-ii, 1+ii, 1), eta(4-ii, 1+ii, 1), zeta(4-ii, 1+ii, 1)]
+ x = [xi(4 - ii, 1 + ii, 1), eta(4 - ii, 1 + ii, 1), &
+ zeta(4 - ii, 1 + ii, 1)]
+ temp(1:nrow, cnt) = x
END DO
+
! edge5, xz
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(4-ii, 1, ii+1), eta(4-ii, 1, ii+1), zeta(4-ii, 1, ii+1)]
+ x = [xi(4 - ii, 1, ii + 1), eta(4 - ii, 1, ii + 1), &
+ zeta(4 - ii, 1, ii + 1)]
+ temp(1:nrow, cnt) = x
END DO
! edge6, yz
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 4-ii, ii+1), eta(1, 4-ii, ii+1), zeta(1, 4-ii, ii+1)]
+ x = [xi(1, 4 - ii, ii + 1), eta(1, 4 - ii, ii + 1), &
+ zeta(1, 4 - ii, ii + 1)]
+ temp(1:nrow, cnt) = x
+
END DO
! facet xy
cnt = cnt + 1
- temp(:, cnt) = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)]
+ x = [xi(2, 2, 1), eta(2, 2, 1), zeta(2, 2, 1)]
+ temp(1:nrow, cnt) = x
! facet xz
cnt = cnt + 1
- temp(:, cnt) = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)]
+ x = [xi(2, 1, 2), eta(2, 1, 2), zeta(2, 1, 2)]
+ temp(1:nrow, cnt) = x
! facet yz
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)]
+ x = [xi(1, 2, 2), eta(1, 2, 2), zeta(1, 2, 2)]
+ temp(1:nrow, cnt) = x
! facet 4
cnt = cnt + 1
- temp(:, cnt) = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)]
+ x = [xi(2, 2, 2), eta(2, 2, 2), zeta(2, 2, 2)]
+ temp(1:nrow, cnt) = x
CASE DEFAULT
! four vertex
- temp(:, 1) = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
- temp(:, 2) = [xi(order+1, 1, 1), eta(order+1, 1, 1), zeta(order+1, 1, 1)]
- temp(:, 3) = [xi(1, order+1, 1), eta(1, order+1, 1), zeta(1, order+1, 1)]
- temp(:, 4) = [xi(1, 1, order+1), eta(1, 1, order+1), zeta(1, 1, order+1)]
+ x = [xi(1, 1, 1), eta(1, 1, 1), zeta(1, 1, 1)]
+ temp(1:nrow, 1) = x
+
+ x = [xi(order + 1, 1, 1), eta(order + 1, 1, 1), zeta(order + 1, 1, 1)]
+ temp(1:nrow, 2) = x
+
+ x = [xi(1, order + 1, 1), eta(1, order + 1, 1), zeta(1, order + 1, 1)]
+ temp(1:nrow, 3) = x
+
+ x = [xi(1, 1, order + 1), eta(1, 1, order + 1), zeta(1, 1, order + 1)]
+ temp(1:nrow, 4) = x
cnt = 4
! edge1 x
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)]
+ x = [xi(1 + ii, 1, 1), eta(1 + ii, 1, 1), zeta(1 + ii, 1, 1)]
+ temp(1:nrow, cnt) = x
+
END DO
! edge2 y
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)]
+ x = [xi(1, 1 + ii, 1), eta(1, 1 + ii, 1), zeta(1, 1 + ii, 1)]
+ temp(1:nrow, cnt) = x
+
END DO
! edge3 z
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)]
+ x = [xi(1, 1, 1 + ii), eta(1, 1, 1 + ii), zeta(1, 1, 1 + ii)]
+ temp(1:nrow, cnt) = x
+
END DO
! edge4 xy
jj = order + 1
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [ &
- & xi(jj - ii, 1 + ii, 1), &
- & eta(jj - ii, 1 + ii, 1), &
- & zeta(jj - ii, 1 + ii, 1)]
+ x = [xi(jj - ii, 1 + ii, 1), eta(jj - ii, 1 + ii, 1), &
+ zeta(jj - ii, 1 + ii, 1)]
+ temp(1:nrow, cnt) = x
END DO
+
! edge5, xz
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [ &
- & xi(jj - ii, 1, ii + 1), &
- & eta(jj - ii, 1, ii + 1), &
- & zeta(jj - ii, 1, ii + 1)]
+ x = [xi(jj - ii, 1, ii + 1), eta(jj - ii, 1, ii + 1), &
+ zeta(jj - ii, 1, ii + 1)]
+ temp(1:nrow, cnt) = x
END DO
+
! edge6, yz
DO ii = 1, order - 1
cnt = cnt + 1
- temp(:, cnt) = [ &
- & xi(1, jj - ii, ii + 1), &
- & eta(1, jj - ii, ii + 1), &
- & zeta(1, jj - ii, ii + 1)]
+ x = [xi(1, jj - ii, ii + 1), eta(1, jj - ii, ii + 1), &
+ zeta(1, jj - ii, ii + 1)]
+ temp(1:nrow, cnt) = x
END DO
! facet xy
jj = LagrangeDOF_Triangle(order)
- CALL IJ2VEFC_Triangle( &
- & xi=xi(:, :, 1), &
- & eta=eta(:, :, 1), &
- & temp=temp_face_in, &
- & order=order, &
- & N=jj)
+ CALL IJ2VEFC_Triangle(xi=xi(:, :, 1), eta=eta(:, :, 1), &
+ temp=temp_face_in, order=order, N=jj)
+
kk = LagrangeInDOF_Triangle(order)
DO ii = jj - kk + 1, jj
cnt = cnt + 1
- temp(:, cnt) = [temp_face_in(1, ii), temp_face_in(2, ii), zeta(1, 1, 1)]
+ x = [temp_face_in(1, ii), temp_face_in(2, ii), zeta(1, 1, 1)]
+ temp(1:nrow, cnt) = x
END DO
! facet xz
! jj = LagrangeDOF_Triangle(order)
- CALL IJ2VEFC_Triangle( &
- & xi=xi(:, 1, :), &
- & eta=zeta(:, 1, :), &
- & temp=temp_face_in, &
- & order=order, &
- & N=jj)
+ CALL IJ2VEFC_Triangle(xi=xi(:, 1, :), eta=zeta(:, 1, :), &
+ temp=temp_face_in, order=order, N=jj)
+
! kk = LagrangeInDOF_Triangle(order)
DO ii = jj - kk + 1, jj
cnt = cnt + 1
- temp(:, cnt) = [temp_face_in(1, ii), eta(1, 1, 1), temp_face_in(2, ii)]
+ x = [temp_face_in(1, ii), eta(1, 1, 1), temp_face_in(2, ii)]
+ temp(1:nrow, cnt) = x
END DO
! facet yz
! jj = LagrangeDOF_Triangle(order)
- CALL IJ2VEFC_Triangle( &
- & xi=eta(1, :, :), &
- & eta=zeta(1, :, :), &
- & temp=temp_face_in, &
- & order=order, &
- & N=jj)
+ CALL IJ2VEFC_Triangle(xi=eta(1, :, :), eta=zeta(1, :, :), &
+ temp=temp_face_in, order=order, N=jj)
! kk = LagrangeInDOF_Triangle(order)
DO ii = jj - kk + 1, jj
cnt = cnt + 1
- temp(:, cnt) = [xi(1, 1, 1), temp_face_in(1, ii), temp_face_in(2, ii)]
+ x = [xi(1, 1, 1), temp_face_in(1, ii), temp_face_in(2, ii)]
+ temp(1:nrow, cnt) = x
END DO
! ! facet 4
@@ -877,23 +999,13 @@
END DO
temp_face_in = 0.0_DFP
- CALL IJK2VEFC_Triangle( &
- & xi=xi2, &
- & eta=eta2, &
- & zeta=zeta2, &
- & temp=temp_face_in, &
- & order=order, &
- & N=SIZE(temp_face_in, 2))
+ CALL IJK2VEFC_Triangle(xi=xi2, eta=eta2, zeta=zeta2, temp=temp_face_in, &
+ order=order, N=SIZE(temp_face_in, 2))
! facet 4
jj = LagrangeDOF_Triangle(order)
- CALL IJK2VEFC_Triangle( &
- & xi=xi2, &
- & eta=eta2, &
- & zeta=zeta2, &
- & temp=temp_face_in, &
- & order=order, &
- & N=jj)
+ CALL IJK2VEFC_Triangle(xi=xi2, eta=eta2, zeta=zeta2, temp=temp_face_in, &
+ order=order, N=jj)
kk = LagrangeInDOF_Triangle(order)
DO ii = jj - kk + 1, jj
cnt = cnt + 1
@@ -902,12 +1014,10 @@
jj = LagrangeDOF_Tetrahedron(order)
kk = LagrangeInDOF_Tetrahedron(order=order)
- CALL IJK2VEFC_Tetrahedron( &
- & xi(2:order - 2, 2:order - 2, 2:order - 2), &
- & eta(2:order - 2, 2:order - 2, 2:order - 2), &
- & zeta(2:order - 2, 2:order - 2, 2:order - 2), &
- & temp(:, cnt + 1:), &
- & order - 4, kk)
+ CALL IJK2VEFC_Tetrahedron(xi(2:order - 2, 2:order - 2, 2:order - 2), &
+ eta(2:order - 2, 2:order - 2, 2:order - 2), &
+ zeta(2:order - 2, 2:order - 2, 2:order - 2), temp(:, cnt + 1:), &
+ order - 4, kk)
END SELECT
END PROCEDURE IJK2VEFC_Tetrahedron
@@ -916,13 +1026,7 @@
! IJ2VEFC_Triangle
!----------------------------------------------------------------------------
-SUBROUTINE IJK2VEFC_Triangle( &
- & xi, &
- & eta, &
- & zeta, &
- & temp, &
- & order, &
- & N)
+SUBROUTINE IJK2VEFC_Triangle(xi, eta, zeta, temp, order, N)
REAL(DFP), INTENT(IN) :: xi(:, :)
REAL(DFP), INTENT(IN) :: eta(:, :)
REAL(DFP), INTENT(IN) :: zeta(:, :)
@@ -1002,6 +1106,7 @@ SUBROUTINE IJK2VEFC_Triangle( &
& unitno=stderr)
RETURN
END IF
+
END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
@@ -1009,6 +1114,16 @@ END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE OrthogonalBasis_Tetrahedron1
+INTEGER(I4B) :: nrow, ncol
+CALL OrthogonalBasis_Tetrahedron1_(order=order, xij=xij, &
+ refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE OrthogonalBasis_Tetrahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalBasis_Tetrahedron1_
CHARACTER(20) :: layout
REAL(DFP) :: x(1:3, 1:SIZE(xij, 2))
REAL(DFP) :: P1(SIZE(xij, 2), 0:order)
@@ -1017,7 +1132,10 @@ END SUBROUTINE IJK2VEFC_Triangle
REAL(DFP) :: x2(SIZE(xij, 2), 0:order)
REAL(DFP) :: x3(SIZE(xij, 2), 0:order)
INTEGER(I4B) :: cnt
-INTEGER(I4B) :: p, q, r
+INTEGER(I4B) :: p, q, r, indx(7)
+
+nrow = SIZE(xij, 2)
+ncol = (order + 1) * (order + 2) * (order + 3) / 6
layout = TRIM(UpperCase(refTetrahedron))
SELECT CASE (TRIM(layout))
@@ -1032,40 +1150,52 @@ END SUBROUTINE IJK2VEFC_Triangle
x3(:, p) = 0.5_DFP * (1.0_DFP - x(3, :))
END DO
-P1 = LegendreEvalAll(n=order, x=x(1, :))
+! P1 = LegendreEvalAll(n=order, x=x(1, :))
+CALL LegendreEvalAll_(n=order, x=x(1, :), ans=P1, nrow=indx(1), ncol=indx(2))
cnt = 0
DO p = 0, order
Q1 = (x2**p) * JacobiEvalAll( &
- & n=order, &
- & x=x(2, :), &
- & alpha=REAL(2 * p + 1, DFP), &
- & beta=0.0_DFP)
+ n=order, &
+ x=x(2, :), &
+ alpha=REAL(2 * p + 1, DFP), &
+ beta=0.0_DFP)
DO q = 0, order - p
R1 = (x3**(p + q)) * JacobiEvalAll( &
- & n=order, &
- & x=x(3, :), &
- & alpha=REAL(2 * p + 2 * q + 2, DFP), &
- & beta=0.0_DFP)
+ n=order, &
+ x=x(3, :), &
+ alpha=REAL(2 * p + 2 * q + 2, DFP), &
+ beta=0.0_DFP)
DO r = 0, order - p - q
cnt = cnt + 1
- ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r)
+ ans(1:nrow, cnt) = P1(1:nrow, p) * Q1(1:nrow, q) * R1(1:nrow, r)
END DO
END DO
+
END DO
-END PROCEDURE OrthogonalBasis_Tetrahedron1
+END PROCEDURE OrthogonalBasis_Tetrahedron1_
!----------------------------------------------------------------------------
! OrthogonalBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE OrthogonalBasis_Tetrahedron2
+INTEGER(I4B) :: nrow, ncol
+CALL OrthogonalBasis_Tetrahedron2_(order=order, x=x, y=y, z=z, &
+ refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE OrthogonalBasis_Tetrahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalBasis_Tetrahedron2_
CHARACTER(20) :: layout
REAL(DFP) :: x0(SIZE(x)), y0(SIZE(y)), z0(SIZE(z))
REAL(DFP) :: xij(3, SIZE(x) * SIZE(y) * SIZE(z))
@@ -1077,6 +1207,9 @@ END SUBROUTINE IJK2VEFC_Triangle
REAL(DFP) :: x3(SIZE(xij, 2), 0:order)
INTEGER(I4B) :: p, q, r
+nrow = SIZE(x) * SIZE(y) * SIZE(z)
+ncol = (order + 1) * (order + 2) * (order + 3) / 6
+
layout = TRIM(UpperCase(refTetrahedron))
SELECT CASE (TRIM(layout))
@@ -1130,21 +1263,37 @@ END SUBROUTINE IJK2VEFC_Triangle
DO r = 0, order - p - q
cnt = cnt + 1
- ans(:, cnt) = P1(:, p) * Q1(:, q) * R1(:, r)
+ ans(1:nrow, cnt) = P1(:, p) * Q1(:, q) * R1(:, r)
END DO
END DO
END DO
-END PROCEDURE OrthogonalBasis_Tetrahedron2
+END PROCEDURE OrthogonalBasis_Tetrahedron2_
!----------------------------------------------------------------------------
! BarycentricVertexBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricVertexBasis_Tetrahedron
-ans = TRANSPOSE(lambda(1:4, :))
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricVertexBasis_Tetrahedron_(lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
END PROCEDURE BarycentricVertexBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricVertexBasis_Tetrahedron_
+INTEGER(I4B) :: ii, jj
+nrow = SIZE(lambda, 2)
+ncol = 4
+
+DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = lambda(jj, ii)
+END DO
+END PROCEDURE BarycentricVertexBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! BarycentricVertexBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1163,127 +1312,125 @@ END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron
-REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2))
-REAL(DFP) :: phi( &
- & 1:6 * SIZE(lambda, 2), &
- & 0:MAX( &
- & pe1 - 2, &
- & pe2 - 2, &
- & pe3 - 2, &
- & pe4 - 2, &
- & pe5 - 2, &
- & pe6 - 2))
-INTEGER(I4B) :: maxP, tPoints, i1, i2
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricEdgeBasis_Tetrahedron_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, &
+ pe5=pe5, pe6=pe6, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricEdgeBasis_Tetrahedron
-tPoints = SIZE(lambda, 2)
-maxP = SIZE(phi, 2) - 1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-i1 = 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(2, :) - lambda(1, :)
+MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron_
+REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2))
+REAL(DFP), ALLOCATABLE :: phi(:, :)
+INTEGER(I4B) :: maxP, indx(7)
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(1, :)
+nrow = SIZE(lambda, 2)
+ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(1, :)
+maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, pe4 - 2, pe5 - 2, pe6 - 2)
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(2, :)
+indx(1) = 6 * nrow
+ALLOCATE (phi(1:indx(1), 0:maxP))
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(2, :)
+indx = [0, 1, 2, 3, 4, 5, 6] * nrow
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(3, :)
+d_lambda(indx(1) + 1:indx(2)) = lambda(2, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(2) + 1:indx(3)) = lambda(3, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(3) + 1:indx(4)) = lambda(4, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(4) + 1:indx(5)) = lambda(3, 1:nrow) - lambda(2, 1:nrow)
+d_lambda(indx(5) + 1:indx(6)) = lambda(4, 1:nrow) - lambda(2, 1:nrow)
+d_lambda(indx(6) + 1:indx(7)) = lambda(4, 1:nrow) - lambda(3, 1:nrow)
-phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
+! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
+CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol)
-ans = BarycentricEdgeBasis_Tetrahedron2( &
- & pe1=pe1, &
- & pe2=pe2, &
- & pe3=pe3, &
- & pe4=pe4, &
- & pe5=pe5, &
- & pe6=pe6, &
- & lambda=lambda, &
- & phi=phi &
- & )
+! ans = BarycentricEdgeBasis_Tetrahedron2
+CALL BarycentricEdgeBasis_Tetrahedron2_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, &
+ pe5=pe5, pe6=pe6, lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol)
-END PROCEDURE BarycentricEdgeBasis_Tetrahedron
+DEALLOCATE (phi)
+
+END PROCEDURE BarycentricEdgeBasis_Tetrahedron_
!----------------------------------------------------------------------------
! BarycentricEdgeBasis_Tetrahedron2
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron2
-INTEGER(I4B) :: tPoints, a, ii, i1, i2
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricEdgeBasis_Tetrahedron2_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, &
+ pe5=pe5, pe6=pe6, lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricEdgeBasis_Tetrahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricEdgeBasis_Tetrahedron2_
+INTEGER(I4B) :: a, ii, i1, i2
REAL(DFP) :: temp(SIZE(lambda, 2))
-ans = 0.0_DFP
-tPoints = SIZE(temp)
+nrow = SIZE(lambda, 2)
+ncol = pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6
!! edge(1) = (v1, v2)
a = 0
-temp = lambda(1, :) * lambda(2, :)
+temp = lambda(1, 1:nrow) * lambda(2, 1:nrow)
i1 = 1
-i2 = i1 + tPoints - 1
+i2 = i1 + nrow - 1
DO ii = 1, pe1 - 1
a = a + 1
- ans(:, a) = temp * phi(i1:i2, ii - 1)
+ ans(1:nrow, a) = temp * phi(i1:i2, ii - 1)
END DO
!! edge(2) = (v1, v3)
-temp = lambda(1, :) * lambda(3, :)
+temp = lambda(1, 1:nrow) * lambda(3, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
+i2 = i1 + nrow - 1
DO ii = 1, pe2 - 1
a = a + 1
- ans(:, a) = temp * phi(i1:i2, ii - 1)
+ ans(1:nrow, a) = temp * phi(i1:i2, ii - 1)
END DO
!! edge(3) = (v1, v4)
-temp = lambda(1, :) * lambda(4, :)
+temp = lambda(1, 1:nrow) * lambda(4, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
+i2 = i1 + nrow - 1
DO ii = 1, pe3 - 1
a = a + 1
- ans(:, a) = temp * phi(i1:i2, ii - 1)
+ ans(1:nrow, a) = temp * phi(i1:i2, ii - 1)
END DO
!! edge(4) = (v2, v3)
-temp = lambda(2, :) * lambda(3, :)
+temp = lambda(2, 1:nrow) * lambda(3, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
+i2 = i1 + nrow - 1
DO ii = 1, pe4 - 1
a = a + 1
- ans(:, a) = temp * phi(i1:i2, ii - 1)
+ ans(1:nrow, a) = temp * phi(i1:i2, ii - 1)
END DO
!! edge(5) = (v2, v4)
-temp = lambda(2, :) * lambda(4, :)
+temp = lambda(2, 1:nrow) * lambda(4, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
+i2 = i1 + nrow - 1
DO ii = 1, pe5 - 1
a = a + 1
- ans(:, a) = temp * phi(i1:i2, ii - 1)
+ ans(1:nrow, a) = temp * phi(i1:i2, ii - 1)
END DO
!! edge(5) = (v3, v4)
-temp = lambda(3, :) * lambda(4, :)
+temp = lambda(3, 1:nrow) * lambda(4, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
+i2 = i1 + nrow - 1
DO ii = 1, pe6 - 1
a = a + 1
- ans(:, a) = temp * phi(i1:i2, ii - 1)
+ ans(1:nrow, a) = temp * phi(i1:i2, ii - 1)
END DO
-END PROCEDURE BarycentricEdgeBasis_Tetrahedron2
+END PROCEDURE BarycentricEdgeBasis_Tetrahedron2_
!----------------------------------------------------------------------------
! BarycentricEdgeBasisGradient_Tetrahedron2
@@ -1291,7 +1438,7 @@ END SUBROUTINE IJK2VEFC_Triangle
MODULE PROCEDURE BarycentricEdgeBasisGradient_Tetrahedron2
INTEGER(I4B) :: a, ii, i1, i2, edges(2, 6), orders(6), iedge, v1, v2, &
- & tPoints
+ tPoints
REAL(DFP) :: temp(SIZE(lambda, 2), 6)
tPoints = SIZE(lambda, 2)
@@ -1326,98 +1473,114 @@ END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricFacetBasis_Tetrahedron_(ps1=ps1, ps2=ps2, ps3=ps3, &
+ ps4=ps4, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricFacetBasis_Tetrahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron_
REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2))
-REAL(DFP) :: phi( &
- & 1:6 * SIZE(lambda, 2), &
- & 0:MAX( &
- & ps1 - 1, &
- & ps2 - 1, &
- & ps3 - 1, &
- & ps4 - 1))
-INTEGER(I4B) :: maxP, tPoints, i1, i2
+REAL(DFP), ALLOCATABLE :: phi(:, :)
-tPoints = SIZE(lambda, 2)
-maxP = SIZE(phi, 2) - 1
+INTEGER(I4B) :: maxP, indx(7)
-i1 = 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(2, :) - lambda(1, :)
+nrow = SIZE(lambda, 2)
+ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 &
+ + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(1, :)
+indx(1) = 6 * nrow
+maxP = MAX(ps1 - 1, ps2 - 1, ps3 - 1, ps4 - 1)
+ALLOCATE (phi(1:indx(1), 0:maxP))
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(1, :)
+indx = [0, 1, 2, 3, 4, 5, 6] * nrow
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(2, :)
+d_lambda(indx(1) + 1:indx(2)) = lambda(2, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(2) + 1:indx(3)) = lambda(3, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(3) + 1:indx(4)) = lambda(4, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(4) + 1:indx(5)) = lambda(3, 1:nrow) - lambda(2, 1:nrow)
+d_lambda(indx(5) + 1:indx(6)) = lambda(4, 1:nrow) - lambda(2, 1:nrow)
+d_lambda(indx(6) + 1:indx(7)) = lambda(4, 1:nrow) - lambda(3, 1:nrow)
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(2, :)
+! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
+CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol)
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(3, :)
+! ans = BarycentricFacetBasis_Tetrahedron2( &
+CALL BarycentricFacetBasis_Tetrahedron2_(ps1=ps1, ps2=ps2, ps3=ps3, &
+ ps4=ps4, lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol)
-phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
-ans = BarycentricFacetBasis_Tetrahedron2( &
- & ps1=ps1, &
- & ps2=ps2, &
- & ps3=ps3, &
- & ps4=ps4, &
- & lambda=lambda, &
- & phi=phi)
+DEALLOCATE (phi)
-END PROCEDURE BarycentricFacetBasis_Tetrahedron
+END PROCEDURE BarycentricFacetBasis_Tetrahedron_
!----------------------------------------------------------------------------
! BarycentricFacetBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron2
-REAL(DFP) :: temp(SIZE(lambda, 2))
-INTEGER(I4B) :: tPoints, i1, i2, ii, a
-INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2)
-INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4)
-
-tPoints = SIZE(temp)
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricFacetBasis_Tetrahedron2_(ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4, &
+ lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricFacetBasis_Tetrahedron2
-i21 = [1, tPoints]
-i31 = i21 + tPoints
-i41 = i31 + tPoints
-i32 = i41 + tPoints
-i42 = i32 + tPoints
-i43 = i42 + tPoints
-facetConn = FacetConnectivity_Tetrahedron( &
- & baseInterpol="HIERARCHY", &
- & baseContinuity="H1")
-indx1 = ((i21.rowconcat.i21) .rowconcat.i31) .rowconcat.i32
-indx2 = ((i31.rowconcat.i41) .rowconcat.i41) .rowconcat.i42
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-ans = 0.0_DFP
+MODULE PROCEDURE BarycentricFacetBasis_Tetrahedron2_
+REAL(DFP) :: temp(SIZE(lambda, 2))
+INTEGER(I4B) :: i1, i2
+INTEGER(I4B) :: i21(2), i31(2), i41(2), i32(2), i42(2), i43(2)
+INTEGER(I4B) :: facetConn(3, 4), fid, n1, n2, cnt, indx1(2, 4), indx2(2, 4)
+
+nrow = SIZE(lambda, 2)
+ncol = (ps1 - 1) * (ps1 - 2) / 2 + (ps2 - 1) * (ps2 - 2) / 2 &
+ + (ps3 - 1) * (ps3 - 2) / 2 + (ps4 - 1) * (ps4 - 2) / 2
+
+i21(1) = 1; i21(2) = nrow
+i31 = i21 + nrow
+i41 = i31 + nrow
+i32 = i41 + nrow
+i42 = i32 + nrow
+i43 = i42 + nrow
+
+facetConn(1:3, 1:4) = &
+ FacetConnectivity_Tetrahedron(baseInterpol="HIERARCHY", baseContinuity="H1")
+
+indx1(1:2, 1) = i21
+indx1(1:2, 2) = i21
+indx1(1:2, 3) = i31
+indx1(1:2, 4) = i32
+
+indx2(1:2, 1) = i31
+indx2(1:2, 2) = i41
+indx2(1:2, 3) = i41
+indx2(1:2, 4) = i42
+
+! ans = 0.0_DFP
i2 = 0
cnt = 0
!! Face1
DO fid = 1, SIZE(facetConn, 2)
- temp = lambda(facetConn(1, fid), :) &
- & * lambda(facetConn(2, fid), :) &
- & * lambda(facetConn(3, fid), :)
+ temp(1:nrow) = lambda(facetConn(1, fid), 1:nrow) &
+ * lambda(facetConn(2, fid), 1:nrow) &
+ * lambda(facetConn(3, fid), 1:nrow)
+
DO n1 = 1, ps1 - 1
DO n2 = 1, ps1 - 1 - n1
cnt = cnt + 1
- ans(:, cnt) = temp &
- & * phi(indx1(1, fid):indx1(2, fid), n1 - 1) &
- & * phi(indx2(1, fid):indx2(2, fid), n2 - 1)
+ ans(1:nrow, cnt) = temp &
+ * phi(indx1(1, fid):indx1(2, fid), n1 - 1) &
+ * phi(indx2(1, fid):indx2(2, fid), n2 - 1)
END DO
END DO
END DO
-END PROCEDURE BarycentricFacetBasis_Tetrahedron2
+END PROCEDURE BarycentricFacetBasis_Tetrahedron2_
!----------------------------------------------------------------------------
! BarycentricFacetBasisGradient_Tetrahedron
@@ -1482,70 +1645,91 @@ END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricCellBasis_Tetrahedron
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricCellBasis_Tetrahedron_(pb=pb, lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricCellBasis_Tetrahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricCellBasis_Tetrahedron_
REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:pb)
INTEGER(I4B) :: maxP, tPoints, i1, i2
-tPoints = SIZE(lambda, 2)
+nrow = SIZE(lambda, 2)
+ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B
+
maxP = SIZE(phi, 2) - 1
i1 = 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(2, :) - lambda(1, :)
+i2 = i1 + nrow - 1
+d_lambda(i1:i2) = lambda(2, 1:nrow) - lambda(1, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(1, :)
+i2 = i1 + nrow - 1
+d_lambda(i1:i2) = lambda(3, 1:nrow) - lambda(1, 1:nrow)
i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(1, :)
+i2 = i1 + nrow - 1
+d_lambda(i1:i2) = lambda(4, 1:nrow) - lambda(1, 1:nrow)
-phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
-ans = BarycentricCellBasis_Tetrahedron2( &
- & pb=pb, &
- & lambda=lambda, &
- & phi=phi)
+! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
+CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol)
-END PROCEDURE BarycentricCellBasis_Tetrahedron
+! ans = BarycentricCellBasis_Tetrahedron2( &
+CALL BarycentricCellBasis_Tetrahedron2_(pb=pb, lambda=lambda, phi=phi, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+END PROCEDURE BarycentricCellBasis_Tetrahedron_
!----------------------------------------------------------------------------
! BarycentricCellBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricCellBasis_Tetrahedron2
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricCellBasis_Tetrahedron2_(pb=pb, lambda=lambda, phi=phi, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricCellBasis_Tetrahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricCellBasis_Tetrahedron2_
REAL(DFP) :: temp(SIZE(lambda, 2))
-INTEGER(I4B) :: tPoints
INTEGER(I4B) :: i21(2), i31(2), i41(2)
INTEGER(I4B) :: n1, n2, n3, cnt
-tPoints = SIZE(temp)
+nrow = SIZE(lambda, 2)
+ncol = (pb - 1) * (pb - 2) * (pb - 3) / 6_I4B
-i21 = [1, tPoints]
-i31 = i21 + tPoints
-i41 = i31 + tPoints
+i21(1) = 1; i21(2) = nrow
+i31 = i21 + nrow
+i41 = i31 + nrow
ans = 0.0_DFP
cnt = 0
-temp = lambda(1, :) &
- & * lambda(2, :) &
- & * lambda(3, :) &
- & * lambda(4, :)
+temp(1:nrow) = lambda(1, 1:nrow) * lambda(2, 1:nrow) &
+ * lambda(3, 1:nrow) * lambda(4, 1:nrow)
DO n1 = 1, pb - 1
DO n2 = 1, pb - 1 - n1
DO n3 = 1, pb - 1 - n1 - n2
cnt = cnt + 1
- ans(:, cnt) = temp &
- & * phi(i21(1):i21(2), n1 - 1) &
- & * phi(i31(1):i31(2), n2 - 1) &
- & * phi(i41(1):i41(2), n3 - 1)
+ ans(1:nrow, cnt) = temp &
+ * phi(i21(1):i21(2), n1 - 1) &
+ * phi(i31(1):i31(2), n2 - 1) &
+ * phi(i41(1):i41(2), n3 - 1)
END DO
END DO
END DO
-END PROCEDURE BarycentricCellBasis_Tetrahedron2
+END PROCEDURE BarycentricCellBasis_Tetrahedron2_
!----------------------------------------------------------------------------
! BarycentricCellBasisGradient_Tetrahedron
@@ -1611,127 +1795,106 @@ END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1
-REAL(DFP) :: phi( &
- & 1:6 * SIZE(lambda, 2), &
- & 0:MAX( &
- & pe1 - 2, &
- & pe2 - 2, &
- & pe3 - 2, &
- & pe4 - 2, &
- & pe5 - 2, &
- & pe6 - 2, &
- & ps1 - 1, &
- & ps2 - 1, &
- & ps3 - 1, &
- & ps4 - 1, &
- & order &
- & ))
-REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2))
-INTEGER(I4B) :: a, b, maxP, tPoints, i1, i2
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricHeirarchicalBasis_Tetrahedron1_(order=order, &
+ pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ps1=ps1, &
+ ps2=ps2, ps3=ps3, ps4=ps4, lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1
-tPoints = SIZE(lambda, 2)
-maxP = SIZE(phi, 2) - 1_I4B
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-i1 = 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(2, :) - lambda(1, :)
+MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1_
+REAL(DFP) :: d_lambda(6 * SIZE(lambda, 2))
+INTEGER(I4B) :: maxP, bint, indx(7)
+REAL(DFP), ALLOCATABLE :: phi(:, :)
+LOGICAL(LGT) :: isok
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(1, :)
+nrow = SIZE(lambda, 2)
+ncol = 0
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(1, :)
+indx(1) = 6 * nrow
+maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, pe4 - 2, pe5 - 2, pe6 - 2, &
+ ps1 - 1, ps2 - 1, ps3 - 1, ps4 - 1, order)
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(3, :) - lambda(2, :)
+ALLOCATE (phi(1:indx(1), 0:maxP))
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(2, :)
+indx = [0, 1, 2, 3, 4, 5, 6] * nrow
-i1 = i2 + 1
-i2 = i1 + tPoints - 1
-d_lambda(i1:i2) = lambda(4, :) - lambda(3, :)
+d_lambda(indx(1) + 1:indx(2)) = lambda(2, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(2) + 1:indx(3)) = lambda(3, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(3) + 1:indx(4)) = lambda(4, 1:nrow) - lambda(1, 1:nrow)
+d_lambda(indx(4) + 1:indx(5)) = lambda(3, 1:nrow) - lambda(2, 1:nrow)
+d_lambda(indx(5) + 1:indx(6)) = lambda(4, 1:nrow) - lambda(2, 1:nrow)
+d_lambda(indx(6) + 1:indx(7)) = lambda(4, 1:nrow) - lambda(3, 1:nrow)
-phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
+! phi = LobattoKernelEvalAll(n=maxP, x=d_lambda)
+CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=indx(1), ncol=indx(2))
!! Vertex basis function
-ans = 0.0_DFP
-ans(:, 1:4) = BarycentricVertexBasis_Tetrahedron(lambda=lambda)
-b = 4
+CALL BarycentricVertexBasis_Tetrahedron_(lambda=lambda, ans=ans, nrow=indx(1), &
+ ncol=bint)
+
+ncol = ncol + bint
!! Edge basis function
-IF (ANY([pe1, pe2, pe3, pe4, pe5, pe6] .GE. 2_I4B)) THEN
- a = b + 1
- b = a - 1 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6
- ans(:, a:b) = BarycentricEdgeBasis_Tetrahedron2( &
- & pe1=pe1, &
- & pe2=pe2, &
- & pe3=pe3, &
- & pe4=pe4, &
- & pe5=pe5, &
- & pe6=pe6, &
- & lambda=lambda, &
- & phi=phi &
- & )
+indx(1:6) = [pe1, pe2, pe3, pe4, pe5, pe6]
+isok = ANY(indx(1:6) .GE. 2_I4B)
+
+IF (isok) THEN
+ CALL BarycentricEdgeBasis_Tetrahedron2_(pe1=pe1, pe2=pe2, pe3=pe3, &
+ pe4=pe4, pe5=pe5, pe6=pe6, lambda=lambda, phi=phi, ans=ans(:, ncol + 1:), &
+ nrow=nrow, ncol=bint)
+
+ ncol = ncol + bint
END IF
!! Facet basis function
-IF (ANY([ps1, ps2, ps3, ps4] .GE. 3_I4B)) THEN
- a = b + 1
- b = a - 1 &
- & + (ps1 - 1_I4B) * (ps1 - 2_I4B) / 2_I4B &
- & + (ps2 - 1_I4B) * (ps2 - 2_I4B) / 2_I4B &
- & + (ps3 - 1_I4B) * (ps3 - 2_I4B) / 2_I4B &
- & + (ps4 - 1_I4B) * (ps4 - 2_I4B) / 2_I4B
-
- ans(:, a:b) = BarycentricFacetBasis_Tetrahedron2( &
- & ps1=ps1, &
- & ps2=ps2, &
- & ps3=ps3, &
- & ps4=ps4, &
- & lambda=lambda, &
- & phi=phi &
- & )
+indx(1:4) = [ps1, ps2, ps3, ps4]
+isok = ANY(indx(1:4) .GE. 3_I4B)
+IF (isok) THEN
+ CALL BarycentricFacetBasis_Tetrahedron2_(ps1=ps1, ps2=ps2, ps3=ps3, &
+ ps4=ps4, lambda=lambda, phi=phi, ans=ans(:, ncol + 1:), nrow=nrow, &
+ ncol=bint)
+
+ ncol = ncol + bint
END IF
!! Cell basis function
-IF (order .GE. 4_I4B) THEN
- a = b + 1
- b = a - 1 &
- & + (order - 1_I4B) * (order - 2_I4B) * (order - 3_I4B) / 6_I4B
+isok = order .GE. 4_I4B
+IF (isok) THEN
+ CALL BarycentricCellBasis_Tetrahedron2_(pb=order, lambda=lambda, phi=phi, &
+ ans=ans(:, ncol + 1:), nrow=nrow, ncol=bint)
- ans(:, a:b) = BarycentricCellBasis_Tetrahedron2( &
- & pb=order, &
- & lambda=lambda, &
- & phi=phi)
+ ncol = ncol + bint
END IF
-END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1
+
+DEALLOCATE (phi)
+
+END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron1_
!----------------------------------------------------------------------------
! BarycentricHeirarchicalBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2
-ans = BarycentricHeirarchicalBasis_Tetrahedron( &
- & order=order, &
- & pe1=order, &
- & pe2=order, &
- & pe3=order, &
- & pe4=order, &
- & pe5=order, &
- & pe6=order, &
- & ps1=order, &
- & ps2=order, &
- & ps3=order, &
- & ps4=order, &
- & lambda=lambda &
- & )
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricHeirarchicalBasis_Tetrahedron2_(order=order, &
+ lambda=lambda, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2_
+CALL BarycentricHeirarchicalBasis_Tetrahedron1_(order=order, pe1=order, &
+ pe2=order, pe3=order, pe4=order, pe5=order, pe6=order, ps1=order, &
+ ps2=order, ps3=order, ps4=order, lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE BarycentricHeirarchicalBasis_Tetrahedron2_
+
!----------------------------------------------------------------------------
! BarycentricHeirarchicalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
@@ -1881,424 +2044,643 @@ END SUBROUTINE IJK2VEFC_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE VertexBasis_Tetrahedron
-ans = BarycentricVertexBasis_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron))
+INTEGER(I4B) :: nrow, ncol
+CALL VertexBasis_Tetrahedron_(xij=xij, refTetrahedron=refTetrahedron, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE VertexBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VertexBasis_Tetrahedron_
+REAL(DFP), ALLOCATABLE :: lambda(:, :)
+
+nrow = SIZE(xij, 2)
+ALLOCATE (lambda(4, nrow))
+
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=nrow, ncol=ncol)
+
+CALL BarycentricVertexBasis_Tetrahedron_(lambda=lambda, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+DEALLOCATE (lambda)
+END PROCEDURE VertexBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! EdgeBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE EdgeBasis_Tetrahedron
-ans = BarycentricEdgeBasis_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron), &
- & pe1=pe1, &
- & pe2=pe2, &
- & pe3=pe3, &
- & pe4=pe4, &
- & pe5=pe5, &
- & pe6=pe6)
+INTEGER(I4B) :: nrow, ncol
+CALL EdgeBasis_Tetrahedron_(pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, &
+ pe6=pe6, xij=xij, refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE EdgeBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EdgeBasis_Tetrahedron_
+REAL(DFP), ALLOCATABLE :: lambda(:, :)
+
+nrow = SIZE(xij, 2)
+ALLOCATE (lambda(4, nrow))
+
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=nrow, ncol=ncol)
+
+CALL BarycentricEdgeBasis_Tetrahedron_(lambda=lambda, pe1=pe1, pe2=pe2, &
+ pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ans=ans, nrow=nrow, ncol=ncol)
+
+DEALLOCATE (lambda)
+END PROCEDURE EdgeBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! FacetBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE FacetBasis_Tetrahedron
-ans = BarycentricFacetBasis_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron), &
- & ps1=ps1, &
- & ps2=ps2, &
- & ps3=ps3, &
- & ps4=ps4)
+INTEGER(I4B) :: nrow, ncol
+CALL FacetBasis_Tetrahedron_(ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4, xij=xij, &
+ refTetrahedron=refTetrahedron, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE FacetBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FacetBasis_Tetrahedron_
+REAL(DFP), ALLOCATABLE :: lambda(:, :)
+
+nrow = SIZE(xij, 2)
+ALLOCATE (lambda(4, nrow))
+
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=nrow, ncol=ncol)
+
+CALL BarycentricFacetBasis_Tetrahedron_(lambda=lambda, ps1=ps1, ps2=ps2, &
+ ps3=ps3, ps4=ps4, ans=ans, nrow=nrow, ncol=ncol)
+
+DEALLOCATE (lambda)
+END PROCEDURE FacetBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! CellBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE CellBasis_Tetrahedron
-ans = BarycentricCellBasis_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron), &
- & pb=pb)
+INTEGER(I4B) :: nrow, ncol
+CALL CellBasis_Tetrahedron_(pb=pb, xij=xij, refTetrahedron=refTetrahedron, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE CellBasis_Tetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE CellBasis_Tetrahedron_
+REAL(DFP), ALLOCATABLE :: lambda(:, :)
+
+nrow = SIZE(xij, 2)
+ALLOCATE (lambda(4, nrow))
+
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=nrow, ncol=ncol)
+
+CALL BarycentricCellBasis_Tetrahedron_(lambda=lambda, pb=pb, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+DEALLOCATE (lambda)
+END PROCEDURE CellBasis_Tetrahedron_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasis_Tetrahedron1
-ans = BarycentricHeirarchicalBasis_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron), &
- & order=order, &
- & pe1=pe1, &
- & pe2=pe2, &
- & pe3=pe3, &
- & pe4=pe4, &
- & pe5=pe5, &
- & pe6=pe6, &
- & ps1=ps1, &
- & ps2=ps2, &
- & ps3=ps3, &
- & ps4=ps4)
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Tetrahedron1_(order, pe1, pe2, pe3, pe4, pe5, pe6, &
+ ps1, ps2, ps3, ps4, xij, refTetrahedron, ans, nrow, ncol)
END PROCEDURE HeirarchicalBasis_Tetrahedron1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Tetrahedron1_
+REAL(DFP), ALLOCATABLE :: lambda(:, :)
+
+nrow = SIZE(xij, 2)
+
+ALLOCATE (lambda(4, nrow))
+
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=nrow, ncol=ncol)
+
+! ans(1:nrow, 1:ncol) = BarycentricHeirarchicalBasis_Tetrahedron( &
+CALL BarycentricHeirarchicalBasis_Tetrahedron_(lambda=lambda, order=order, &
+ pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ps1=ps1, ps2= &
+ ps2, ps3=ps3, ps4=ps4, ans=ans, nrow=nrow, ncol=ncol)
+
+DEALLOCATE (lambda)
+END PROCEDURE HeirarchicalBasis_Tetrahedron1_
+
!----------------------------------------------------------------------------
! HeirarchicalBasis_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasis_Tetrahedron2
-ans = BarycentricHeirarchicalBasis_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron), &
- & order=order)
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Tetrahedron2_(order, xij, refTetrahedron, ans, nrow, &
+ ncol)
END PROCEDURE HeirarchicalBasis_Tetrahedron2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Tetrahedron2_
+REAL(DFP), ALLOCATABLE :: lambda(:, :)
+
+nrow = SIZE(xij, 2)
+ALLOCATE (lambda(4, nrow))
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=nrow, ncol=ncol)
+
+CALL BarycentricHeirarchicalBasis_Tetrahedron_(lambda=lambda, order=order, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+DEALLOCATE (lambda)
+END PROCEDURE HeirarchicalBasis_Tetrahedron2_
+
!----------------------------------------------------------------------------
! LagrangeEvallAll_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Tetrahedron1
+INTEGER(I4B) :: tsize
+CALL LagrangeEvalAll_Tetrahedron1_(order=order, x=x, xij=xij, ans=ans, &
+ tsize=tsize, refTetrahedron=refTetrahedron, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+END PROCEDURE LagrangeEvalAll_Tetrahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Tetrahedron1_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof
+INTEGER(I4B) :: ii, basisType0, nrow, ncol
INTEGER(I4B) :: degree(SIZE(xij, 2), 3)
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2))
-TYPE(String) :: ref0
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), &
+ x31(3, 1)
+CHARACTER(:), ALLOCATABLE :: ref0
+
+tsize = SIZE(xij, 2)
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
+
ref0 = INPUT(default="UNIT", option=refTetrahedron)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & refTetrahedron=ref0%chars() &
- & )
- coeff0 = TRANSPOSE(coeff)
- ELSE
- coeff0 = TRANSPOSE(coeff)
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ refTetrahedron=ref0, ans=coeff, nrow=nrow, ncol=ncol)
END IF
+
+ coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize)
+
ELSE
- coeff0 = TRANSPOSE( &
- & LagrangeCoeff_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & refTetrahedron=ref0%chars() &
- & ))
+ ! coeff0 = TRANSPOSE( &
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ refTetrahedron=ref0, ans=coeff0, nrow=nrow, ncol=ncol)
END IF
SELECT CASE (basisType0)
CASE (Monomial)
- degree = LagrangeDegree_Tetrahedron(order=order)
- tdof = SIZE(xij, 2)
+ ! degree = LagrangeDegree_Tetrahedron(order=order)
+ CALL LagrangeDegree_Tetrahedron_(order=order, ans=degree, nrow=nrow, &
+ ncol=ncol)
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Tetrahedron1", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+
+ IF (tsize .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Tetrahedron1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
- DO ii = 1, tdof
- xx(1, ii) = x(1)**degree(ii, 1) &
- & * x(2)**degree(ii, 2) &
- & * x(3)**degree(ii, 3)
+#endif
+
+ DO ii = 1, tsize
+ xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2) * x(3)**degree(ii, 3)
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasis_Tetrahedron( &
- & order=order, &
- & xij=RESHAPE(x, [3, 1]), &
- & refTetrahedron=ref0%chars())
+ ! FIXME:
+ x31(1:3, 1) = x(1:3)
+ ! xx = HeirarchicalBasis_Tetrahedron(order=order, xij=x31, refTetrahedron=ref0)
+ call HeirarchicalBasis_Tetrahedron_(order=order, xij=x31, refTetrahedron=ref0, &
+ ans=xx, nrow=nrow, ncol=ncol)
CASE DEFAULT
- xx = OrthogonalBasis_Tetrahedron( &
- & order=order, &
- & xij=RESHAPE(x, [3, 1]), &
- & refTetrahedron=ref0%chars() &
- & )
+
+ !FIXME:
+ x31(1:3, 1) = x(1:3)
+CALL OrthogonalBasis_Tetrahedron_(order=order, xij=x31, refTetrahedron=ref0, &
+ ans=xx, nrow=nrow, ncol=ncol)
END SELECT
-ans = MATMUL(coeff0, xx(1, :))
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :))
+END DO
-END PROCEDURE LagrangeEvalAll_Tetrahedron1
+END PROCEDURE LagrangeEvalAll_Tetrahedron1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Tetrahedron2
+INTEGER(I4B) :: nrow, ncol
+CALL LagrangeEvalAll_Tetrahedron2_(order=order, x=x, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol, refTetrahedron=refTetrahedron, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+END PROCEDURE LagrangeEvalAll_Tetrahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Tetrahedron2_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof
-INTEGER(I4B) :: degree(SIZE(xij, 2), 3)
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2))
-REAL(DFP) :: xx(SIZE(x, 2), SIZE(xij, 2))
-TYPE(String) :: ref0
+
+INTEGER(I4B) :: ii, jj, basisType0, indx(7), degree(SIZE(xij, 2), 3)
+
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), &
+ xx(SIZE(x, 2), SIZE(xij, 2)), areal
+
+CHARACTER(:), ALLOCATABLE :: ref0
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
ref0 = INPUT(default="UNIT", option=refTetrahedron)
IF (PRESENT(coeff)) THEN
+
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & refTetrahedron=ref0%chars() &
- & )
+
+ ! coeff = LagrangeCoeff_Tetrahedron(&
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ refTetrahedron=ref0, ans=coeff, nrow=indx(1), ncol=indx(2))
+
END IF
- coeff0 = coeff
+
+ coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol)
+
ELSE
- coeff0 = LagrangeCoeff_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & refTetrahedron=ref0%chars() &
- & )
+
+ ! coeff0 = LagrangeCoeff_Tetrahedron(&
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ refTetrahedron=ref0, ans=coeff0, nrow=indx(1), ncol=indx(2))
END IF
SELECT CASE (basisType0)
CASE (Monomial)
- degree = LagrangeDegree_Tetrahedron(order=order)
- tdof = SIZE(xij, 2)
+ ! degree = LagrangeDegree_Tetrahedron(order=order)
+ CALL LagrangeDegree_Tetrahedron_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Tetrahedron1", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+ IF (ncol .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Tetrahedron1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
+#endif
+
+ DO ii = 1, ncol
+ indx(1:3) = degree(ii, 1:3)
+
+ DO jj = 1, nrow
+ areal = x(1, jj)**indx(1) * x(2, jj)**indx(2) * x(3, jj)**indx(3)
+ xx(jj, ii) = areal
+ END DO
- DO ii = 1, tdof
- xx(:, ii) = x(1, :)**degree(ii, 1) &
- & * x(2, :)**degree(ii, 2) &
- & * x(3, :)**degree(ii, 3)
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasis_Tetrahedron( &
- & order=order, &
- & xij=x, &
- & refTetrahedron=ref0%chars())
+ CALL HeirarchicalBasis_Tetrahedron_(order=order, xij=x, &
+ refTetrahedron=ref0, ans=xx, nrow=indx(1), ncol=indx(2))
CASE DEFAULT
- xx = OrthogonalBasis_Tetrahedron( &
- & order=order, &
- & xij=x, &
- & refTetrahedron=ref0%chars() &
- & )
+ CALL OrthogonalBasis_Tetrahedron_(order=order, xij=x, refTetrahedron=ref0, &
+ ans=xx, nrow=indx(1), ncol=indx(2))
END SELECT
-ans = MATMUL(xx, coeff0)
+! ans = MATMUL(xx, coeff0)
-END PROCEDURE LagrangeEvalAll_Tetrahedron2
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0)
+
+END PROCEDURE LagrangeEvalAll_Tetrahedron2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadratureNumber_Tetrahedron
+INTEGER(I4B) :: n
+
+ans = QuadratureNumberTetrahedronSolin(order=order)
+
+IF (ans .LT. 0) THEN
+ n = 1_I4B + INT(order / 2, kind=I4B)
+ ans = n * (n + 1) * n
+END IF
+
+END PROCEDURE QuadratureNumber_Tetrahedron
!----------------------------------------------------------------------------
! QuadraturePoint_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Tetrahedron1
-REAL(DFP), ALLOCATABLE :: temp_t(:, :)
-TYPE(string) :: astr
-
-IF (order .LE. MAX_ORDER_TETRAHEDRON_SOLIN) THEN
- astr = TRIM(UpperCase(refTetrahedron))
- temp_t = QuadraturePointTetrahedronSolin(order=order)
- CALL Reallocate(ans, 4_I4B, SIZE(temp_t, 2, kind=I4B))
-
- IF (PRESENT(xij)) THEN
- ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( &
- & xin=temp_t(1:3, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4) &
- & )
+INTEGER(I4B) :: nrow, ncol, n
- ans(4, :) = temp_t(4, :) * JacobianTetrahedron( &
- & from="UNIT", &
- & to="TETRAHEDRON", &
- & xij=xij)
+nrow = 4
+ncol = QuadratureNumber_Tetrahedron(order=order, quadType=quadType)
- ELSE
+ALLOCATE (ans(nrow, ncol))
- IF (astr%chars() .EQ. "BIUNIT") THEN
- ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :))
- ans(4, :) = temp_t(4, :) * JacobianTetrahedron( &
- & from="UNIT", &
- & to="BIUNIT")
+CALL QuadraturePoint_Tetrahedron1_(order, quadType, refTetrahedron, xij, &
+ ans, nrow, ncol)
- ELSE
- ans = temp_t
- END IF
- END IF
+END PROCEDURE QuadraturePoint_Tetrahedron1
- IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
-ELSE
- ans = TensorQuadraturepoint_Tetrahedron( &
- & order=order, &
- & quadtype=quadtype, &
- & refTetrahedron=refTetrahedron, &
- & xij=xij)
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Tetrahedron1_
+INTEGER(I4B), PARAMETER :: nsd = 3
+CHARACTER(1) :: astr
+INTEGER(I4B) :: ii, jj
+REAL(DFP) :: areal
+LOGICAL(LGT) :: abool
+
+abool = order .GT. MAX_ORDER_TETRAHEDRON_SOLIN
+IF (abool) THEN
+ CALL TensorQuadraturepoint_Tetrahedron_(order=order, quadtype=quadtype, &
+ refTetrahedron=refTetrahedron, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+ RETURN
END IF
-END PROCEDURE QuadraturePoint_Tetrahedron1
+
+CALL QuadraturePointTetrahedronSolin(order=order, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+! CALL Reallocate(ans, 4_I4B, SIZE(temp_t, 2, kind=I4B))
+
+IF (PRESENT(xij)) THEN
+ ! ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( &
+ CALL FromUnitTetrahedron2Tetrahedron_(xin=ans(1:nsd, 1:ncol), &
+ x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, &
+ nrow=ii, ncol=jj)
+
+ areal = JacobianTetrahedron(from="UNIT", to="TETRAHEDRON", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
+
+END IF
+
+astr = UpperCase(reftetrahedron(1:1))
+
+IF (astr .EQ. "B") THEN
+
+ CALL FromUnitTetrahedron2BiUnitTetrahedron_(xin=ans(1:nsd, 1:ncol), &
+ nrow=ii, ncol=jj, ans=ans)
+
+ areal = JacobianTetrahedron(from="UNIT", to="BIUNIT")
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+END IF
+
+END PROCEDURE QuadraturePoint_Tetrahedron1_
!----------------------------------------------------------------------------
! QuadraturePoint_Tetrahedron2
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Tetrahedron2
+INTEGER(I4B) :: nrow, ncol
+nrow = 4
+ncol = nips(1)
+ALLOCATE (ans(nrow, ncol))
+CALL QuadraturePoint_Tetrahedron2_(nips=nips, quadType=quadType, &
+ refTetrahedron=refTetrahedron, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE QuadraturePoint_Tetrahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Tetrahedron2_
INTEGER(I4B) :: order
+
order = QuadratureOrderTetrahedronSolin(nips(1))
+
IF (order .LT. 0) THEN
- ans = Quadraturepoint_Tetrahedron1( &
- & order=order, &
- & quadtype=quadType, &
- & refTetrahedron=refTetrahedron, &
- & xij=xij)
-ELSE
- CALL Errormsg(&
- & msg="This routine is available for nips = [ &
- & 1, 4, 5, 11, 14, 24, 31, 43, 53, 126, 210, 330, 495, 715, 1001] &
+
+ CALL Errormsg( &
+ msg="This routine is available for nips = [&
+ & 1, 4, 5, 11, 14, 24, 31, 43, 53, 126, 210, 330, 495, 715, 1001] &
& TRY CALLING TensorQuadraturePoint_Tetrahedron() instead.", &
- & file=__FILE__, &
- & routine="QuadraturePoint_Tetrahedron2()", &
- & line=__LINE__, &
- & unitno=stderr)
+ routine="QuadraturePoint_Tetrahedron2()", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
+
+ nrow = 0; ncol = 0
+ RETURN
+
END IF
-END PROCEDURE QuadraturePoint_Tetrahedron2
+
+CALL Quadraturepoint_Tetrahedron1_(order=order, quadtype=quadType, &
+ refTetrahedron=refTetrahedron, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE QuadraturePoint_Tetrahedron2_
!----------------------------------------------------------------------------
! TensorQuadraturePoint_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron1
-INTEGER(I4B) :: n(4)
+INTEGER(I4B) :: n(3), nrow, ncol
+
n = 1_I4B + INT(order / 2, kind=I4B)
n(2) = n(2) + 1
-ans = TensorQuadraturePoint_Tetrahedron2( &
- & nipsx=n(1), &
- & nipsy=n(2), &
- & nipsz=n(3), &
- & quadType=quadType, &
- & refTetrahedron=refTetrahedron, &
- & xij=xij)
+
+nrow = 4
+ncol = n(1) * n(2) * n(3)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL TensorQuadraturePoint_Tetrahedron2_(nipsx=n(1), nipsy=n(2), &
+ nipsz=n(3), quadType=quadType, reftetrahedron=reftetrahedron, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE TensorQuadraturePoint_Tetrahedron1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron1_
+INTEGER(I4B) :: n(3)
+
+n = 1_I4B + INT(order / 2, kind=I4B)
+n(2) = n(2) + 1
+
+CALL TensorQuadraturePoint_Tetrahedron2_(nipsx=n(1), nipsy=n(2), &
+ nipsz=n(3), quadType=quadType, refTetrahedron=refTetrahedron, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+END PROCEDURE TensorQuadraturePoint_Tetrahedron1_
+
!----------------------------------------------------------------------------
! TensorQuadraturePoint_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron2
-INTEGER(I4B) :: n(3), nsd
-REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :)
-TYPE(String) :: astr
-
-astr = TRIM(UpperCase(refTetrahedron))
-n(1) = nipsx(1)
-n(2) = nipsy(1)
-n(3) = nipsz(1)
-
-temp_q = QuadraturePoint_Hexahedron(&
- & nipsx=n(1:1), &
- & nipsy=n(2:2), &
- & nipsz=n(3:3), &
- & quadType1=GaussLegendreLobatto, &
- & quadType2=GaussJacobiRadauLeft, &
- & quadType3=GaussJacobiRadauLeft, &
- & refHexahedron="BIUNIT", &
- & alpha2=1.0_DFP, &
- & beta2=0.0_DFP, &
- & alpha3=2.0_DFP, &
- & beta3=0.0_DFP)
-
-CALL Reallocate(temp_t, SIZE(temp_q, 1, KIND=I4B), SIZE(temp_q, 2, KIND=I4B))
-temp_t(1:3, :) = FromBiUnitHexahedron2UnitTetrahedron(xin=temp_q(1:3, :))
-temp_t(4, :) = temp_q(4, :) / 8.0_DFP
-nsd = 3_I4B
-CALL Reallocate(ans, 4_I4B, SIZE(temp_q, 2, KIND=I4B))
+INTEGER(I4B) :: nrow, ncol
+
+nrow = 4
+ncol = nipsx(1) * nipsy(1) * nipsz(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL TensorQuadraturePoint_Tetrahedron2_(nipsx=nipsx, nipsy=nipsy, &
+ nipsz=nipsz, quadType=quadType, refTetrahedron=refTetrahedron, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE TensorQuadraturePoint_Tetrahedron2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorQuadraturePoint_Tetrahedron2_
+INTEGER(I4B), PARAMETER :: nsd = 3
+REAL(DFP), PARAMETER :: one_by_8 = 1.0_DFP / 8.0_DFP
+
+REAL(DFP) :: areal
+
+INTEGER(I4B) :: ii, jj
+CHARACTER(1) :: astr
+
+nrow = 4
+ncol = nipsx(1) * nipsy(1) * nipsz(1)
+
+! temp_q = QuadraturePoint_Hexahedron(&
+CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadType1=GaussLegendreLobatto, quadType2=GaussJacobiRadauLeft, &
+ quadType3=GaussJacobiRadauLeft, refHexahedron="BIUNIT", alpha2=1.0_DFP, &
+ beta2=0.0_DFP, alpha3=2.0_DFP, beta3=0.0_DFP, ans=ans, nrow=ii, ncol=jj)
+
+! ans(1:nsd, :) = FromBiUnitHexahedron2UnitTetrahedron(xin=temp_q(1:3, :))
+CALL FromBiUnitHexahedron2UnitTetrahedron_(xin=ans(1:nsd, 1:ncol), ans=ans, &
+ nrow=ii, ncol=jj)
+
+DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * one_by_8
+END DO
IF (PRESENT(xij)) THEN
- ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( &
- & xin=temp_t(1:3, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4) &
- & )
- ans(4, :) = temp_t(4, :) * JacobianTetrahedron( &
- & from="UNIT", &
- & to="TETRAHEDRON", &
- & xij=xij)
-ELSE
- IF (astr%chars() .EQ. "BIUNIT") THEN
- ans(1:3, :) = FromUnitTetrahedron2BiUnitTetrahedron(xin=temp_t(1:3, :))
- ans(4, :) = temp_t(4, :) * JacobianTetrahedron( &
- & from="UNIT", &
- & to="BIUNIT")
- ELSE
- ans = temp_t
- END IF
+
+ ! ans(1:3, :) = FromUnitTetrahedron2Tetrahedron( &
+ CALL FromUnitTetrahedron2Tetrahedron_(xin=ans(1:nsd, 1:ncol), &
+ x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3), x4=xij(:, 4), ans=ans, &
+ nrow=ii, ncol=jj)
+
+ areal = JacobianTetrahedron(from="UNIT", to="TETRAHEDRON", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
END IF
-IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q)
-IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
-END PROCEDURE TensorQuadraturePoint_Tetrahedron2
+astr = UpperCase(reftetrahedron(1:1))
+
+IF (astr .EQ. "B") THEN
+ CALL FromUnitTetrahedron2BiUnitTetrahedron_(xin=ans(1:nsd, 1:ncol), &
+ ans=ans, nrow=ii, ncol=jj)
+
+ areal = JacobianTetrahedron(from="UNIT", to="BIUNIT")
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+ RETURN
+END IF
+
+END PROCEDURE TensorQuadraturePoint_Tetrahedron2_
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Tetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll_Tetrahedron1
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll_Tetrahedron1_(order=order, x=x, xij=xij, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, refTetrahedron=refTetrahedron, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Tetrahedron1_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, ci
-INTEGER(I4B) :: degree(SIZE(xij, 2), 3)
+INTEGER(I4B) :: ii, basisType0, ai, bi, ci, degree(SIZE(xij, 2), 3), &
+ indx(3), jj
REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), &
- & xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr
-TYPE(String) :: ref0
+ xx(SIZE(x, 2), SIZE(xij, 2), 3), ar, br, cr, areal, breal, creal
+CHARACTER(:), ALLOCATABLE :: ref0
+
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = 3
basisType0 = INPUT(default=Monomial, option=basisType)
firstCall0 = INPUT(default=.TRUE., option=firstCall)
@@ -2306,47 +2688,40 @@ END SUBROUTINE IJK2VEFC_Triangle
IF (PRESENT(coeff)) THEN
IF (firstCall0) THEN
- coeff = LagrangeCoeff_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & refTetrahedron=ref0%chars() &
- & )
+ ! coeff = LagrangeCoeff_Tetrahedron(order=order, xij=xij, &
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, &
+ basisType=basisType0, alpha=alpha, beta=beta, lambda=lambda, &
+ refTetrahedron=ref0, ans=coeff, nrow=indx(1), ncol=indx(2))
+
END IF
- coeff0 = coeff
+
+ coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2)
+
ELSE
- coeff0 = LagrangeCoeff_Tetrahedron(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda, &
- & refTetrahedron=ref0%chars() &
- & )
+
+ CALL LagrangeCoeff_Tetrahedron_(order=order, xij=xij, ans=coeff0, &
+ nrow=indx(1), ncol=indx(2), basisType=basisType0, alpha=alpha, &
+ beta=beta, lambda=lambda, refTetrahedron=ref0)
END IF
SELECT CASE (basisType0)
CASE (Monomial)
- degree = LagrangeDegree_Tetrahedron(order=order)
- tdof = SIZE(xij, 2)
+ CALL LagrangeDegree_Tetrahedron_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
- IF (tdof .NE. SIZE(degree, 1)) THEN
- CALL Errormsg(&
- & msg="tdof is not same as size(degree,1)", &
- & file=__FILE__, &
- & routine="LagrangeEvalAll_Tetrahedron1", &
- & line=__LINE__, &
- & unitno=stderr)
+#ifdef DEBUG_VER
+ IF (dim2 .NE. SIZE(degree, 1)) THEN
+ CALL Errormsg(msg="tdof is not same as size(degree,1)", &
+ routine="LagrangeEvalAll_Tetrahedron1", &
+ file=__FILE__, line=__LINE__, unitno=stderr)
RETURN
END IF
- DO ii = 1, tdof
+#endif
+
+ DO ii = 1, dim2
ai = MAX(degree(ii, 1_I4B) - 1_I4B, 0_I4B)
bi = MAX(degree(ii, 2_I4B) - 1_I4B, 0_I4B)
ci = MAX(degree(ii, 3_I4B) - 1_I4B, 0_I4B)
@@ -2355,42 +2730,39 @@ END SUBROUTINE IJK2VEFC_Triangle
br = REAL(degree(ii, 2_I4B), DFP)
cr = REAL(degree(ii, 3_I4B), DFP)
- xx(:, ii, 1) = (ar * x(1, :)**ai) * &
- & x(2, :)**degree(ii, 2) * &
- & x(3, :)**degree(ii, 3)
+ indx(1:3) = degree(ii, 1:3)
- xx(:, ii, 2) = x(1, :)**degree(ii, 1) * &
- & (br * x(2, :)**bi) * &
- & x(3, :)**degree(ii, 3)
+ DO jj = 1, dim1
+ areal = (ar * x(1, jj)**ai) * x(2, jj)**indx(2) * x(3, jj)**indx(3)
+ breal = x(1, jj)**indx(1) * (br * x(2, jj)**bi) * x(3, jj)**indx(3)
+ creal = x(1, jj)**indx(1) * x(2, jj)**indx(2) * (cr * x(2, jj)**ci)
+
+ xx(jj, ii, 1) = areal
+ xx(jj, ii, 2) = breal
+ xx(jj, ii, 3) = creal
+ END DO
- xx(:, ii, 3) = x(1, :)**degree(ii, 1) * &
- & x(2, :)**degree(ii, 2) * &
- & (cr * x(2, :)**ci)
END DO
CASE (Heirarchical)
- xx = HeirarchicalBasisGradient_Tetrahedron( &
- & order=order, &
- & xij=x, &
- & refTetrahedron=ref0%chars())
+ xx = HeirarchicalBasisGradient_Tetrahedron(order=order, xij=x, &
+ refTetrahedron=ref0)
CASE DEFAULT
-
- xx = OrthogonalBasisGradient_Tetrahedron( &
- & order=order, &
- & xij=x, &
- & refTetrahedron=ref0%chars() &
- & )
+ xx = OrthogonalBasisGradient_Tetrahedron(order=order, xij=x, &
+ refTetrahedron=ref0)
END SELECT
DO ii = 1, 3
! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
- ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0)
+ ans(1:dim1, 1:dim2, ii) = MATMUL(xx(:, :, ii), coeff0)
END DO
-END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1
+ref0 = ""
+
+END PROCEDURE LagrangeGradientEvalAll_Tetrahedron1_
!----------------------------------------------------------------------------
! OrthogonalBasisGradient_Tetrahedron
@@ -2527,42 +2899,201 @@ END SUBROUTINE IJK2VEFC_Triangle
END PROCEDURE OrthogonalBasisGradient_Tetrahedron1
!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Tetrahedron
+! OrthogonalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
-MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1
-TYPE(String) :: name
-REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), 4)
-ans0 = BarycentricHeirarchicalBasisGradient_Tetrahedron(&
- & lambda=BarycentricCoordTetrahedron( &
- & xin=xij, &
- & refTetrahedron=refTetrahedron), &
- & order=order, &
- & pe1=pe1, &
- & pe2=pe2, &
- & pe3=pe3, &
- & pe4=pe4, &
- & pe5=pe5, &
- & pe6=pe6, &
- & ps1=ps1, &
- & ps2=ps2, &
- & ps3=ps3, &
- & ps4=ps4)
-
-ans(:, :, 1) = ans0(:, :, 2) - ans0(:, :, 1)
-ans(:, :, 2) = ans0(:, :, 3) - ans0(:, :, 1)
-ans(:, :, 3) = ans0(:, :, 4) - ans0(:, :, 1)
-
-name = UpperCase(refTetrahedron)
-IF (name == "BIUNIT") THEN
- ans = 0.5_DFP * ans
+MODULE PROCEDURE OrthogonalBasisGradient_Tetrahedron1_
+CHARACTER(1) :: layout
+REAL(DFP) :: x(1:3, 1:SIZE(xij, 2))
+REAL(DFP) :: P1(SIZE(xij, 2), 0:order)
+REAL(DFP) :: Q1(SIZE(xij, 2), 0:order)
+REAL(DFP) :: R1(SIZE(xij, 2), 0:order)
+REAL(DFP) :: dP1(SIZE(xij, 2), 0:order)
+REAL(DFP) :: dQ1(SIZE(xij, 2), 0:order)
+REAL(DFP) :: dR1(SIZE(xij, 2), 0:order)
+REAL(DFP) :: temp(SIZE(xij, 2), 10), areal, breal
+INTEGER(I4B) :: cnt
+INTEGER(I4B) :: p, q, r
+LOGICAL(LGT) :: isBiunit
+REAL(DFP) :: ans0(SIZE(ans, 1), SIZE(ans, 2), SIZE(ans, 3))
+
+dim1 = SIZE(xij, 2)
+dim2 = (order + 1) * (order + 2) * (order + 3) / 6
+dim3 = 3
+
+ans0 = 0.0_DFP
+layout = UpperCase(refTetrahedron(1:1))
+
+SELECT CASE (layout)
+CASE ("B")
+ x = FromBiUnitTetrahedron2BiUnitHexahedron(xin=xij)
+ isBiunit = .TRUE.
+CASE ("U")
+ x = FromUnitTetrahedron2BiUnitHexahedron(xin=xij)
+ isBiunit = .FALSE.
+END SELECT
+
+temp(:, 1) = 0.5_DFP * (1.0_DFP - x(2, :))
+temp(:, 2) = 0.5_DFP * (1.0_DFP - x(3, :))
+
+P1 = LegendreEvalAll(n=order, x=x(1, :))
+dP1 = LegendreGradientEvalAll(n=order, x=x(1, :))
+cnt = 0
+
+DO p = 0, order
+ areal = -0.5_DFP * REAL(p, DFP)
+
+ Q1 = JacobiEvalAll( &
+ & n=order, &
+ & x=x(2, :), &
+ & alpha=REAL(2 * p + 1, DFP), &
+ & beta=0.0_DFP &
+ & )
+
+ dQ1 = JacobiGradientEvalAll( &
+ & n=order, &
+ & x=x(2, :), &
+ & alpha=REAL(2 * p + 1, DFP), &
+ & beta=0.0_DFP &
+ & )
+
+ temp(:, 3) = temp(:, 1)**MAX(p - 1_I4B, 0_I4B)
+ temp(:, 4) = temp(:, 3) * temp(:, 1)
+
+ DO q = 0, order - p
+
+ breal = -0.5_DFP * REAL(p + q, DFP)
+
+ R1 = JacobiEvalAll( &
+ & n=order, &
+ & x=x(3, :), &
+ & alpha=REAL(2 * p + 2 * q + 2, DFP), &
+ & beta=0.0_DFP &
+ & )
+
+ dR1 = JacobiGradientEvalAll( &
+ & n=order, &
+ & x=x(3, :), &
+ & alpha=REAL(2 * p + 2 * q + 2, DFP), &
+ & beta=0.0_DFP &
+ & )
+
+ temp(:, 5) = P1(:, p) * Q1(:, q)
+ temp(:, 6) = P1(:, p) * dQ1(:, q)
+ temp(:, 7) = dP1(:, p) * Q1(:, q)
+ temp(:, 9) = temp(:, 2)**MAX(p + q - 1_I4B, 0_I4B)
+ temp(:, 10) = temp(:, 9) * temp(:, 2)
+
+ DO r = 0, order - p - q
+ temp(:, 8) = temp(:, 5) * R1(:, r)
+ cnt = cnt + 1
+ ans0(:, cnt, 1) = temp(:, 7) * R1(:, r) * temp(:, 4) * temp(:, 10)
+ ans0(:, cnt, 2) = temp(:, 8) * areal * temp(:, 3) * temp(:, 10) &
+ + temp(:, 6) * R1(:, r) * temp(:, 4) * temp(:, 10)
+ ans0(:, cnt, 2) = temp(:, 8) * breal * temp(:, 4) * temp(:, 9) &
+ + temp(:, 5) * dR1(:, r) * temp(:, 4) * temp(:, 10)
+ END DO
+ END DO
+END DO
+
+IF (isBiunit) THEN
+ temp(:, 1) = x(1, :)
+ temp(:, 2) = x(2, :)
+ temp(:, 3) = x(3, :)
+
+ temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3))
+ temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3))
+ temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3))
+ temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2
+
+ DO CONCURRENT(p=1:dim2)
+ ans(1:dim1, p, 1) = -temp(:, 4) * ans0(:, p, 1)
+ ans(1:dim1, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2)
+ ans(1:dim1, p, 3) = temp(:, 5) * ans0(:, p, 1) &
+ + temp(:, 7) * ans0(:, p, 2) &
+ + ans0(:, p, 3)
+ END DO
+
+ELSE
+
+ temp(:, 1:3) = FromUnitTetrahedron2BiUnitTetrahedron(x)
+
+ temp(:, 4) = 2.0_DFP / (temp(:, 2) + temp(:, 3))
+ temp(:, 5) = (1.0_DFP + temp(:, 1)) * temp(:, 4) / (temp(:, 2) + temp(:, 3))
+ temp(:, 6) = 2.0_DFP / (1.0_DFP - temp(:, 3))
+ temp(:, 7) = 1.0_DFP / (1.0_DFP - temp(:, 3))**2
+
+ DO CONCURRENT(p=1:dim2)
+ ans(1:dim1, p, 1) = -temp(:, 4) * ans0(:, p, 1)
+ ans(1:dim1, p, 2) = temp(:, 5) * ans0(:, p, 1) + temp(:, 6) * ans0(:, p, 2)
+ ans(1:dim1, p, 3) = temp(:, 5) * ans0(:, p, 1) &
+ & + temp(:, 7) * ans0(:, p, 2) &
+ & + ans0(:, p, 3)
+ END DO
+
+ ans(1:dim1, 1:dim2, 1:dim3) = 2.0_DFP * ans(1:dim1, 1:dim2, 1:dim3)
+
END IF
+
+END PROCEDURE OrthogonalBasisGradient_Tetrahedron1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL HeirarchicalBasisGradient_Tetrahedron1_(order=order, pe1=pe1, pe2=pe2, &
+ pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4, &
+ xij=xij, refTetrahedron=refTetrahedron, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3)
END PROCEDURE HeirarchicalBasisGradient_Tetrahedron1
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Tetrahedron
!----------------------------------------------------------------------------
+MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron1_
+CHARACTER(1) :: name
+REAL(DFP), ALLOCATABLE :: ans0(:, :, :), lambda(:, :)
+INTEGER(I4B) :: indx(2)
+
+dim1 = SIZE(xij, 2)
+
+dim2 = 4 + pe1 + pe2 + pe3 + pe4 + pe5 + pe6 - 6 &
+ + (ps1 - 1) * (ps1 - 2) / 2 &
+ + (ps2 - 1) * (ps2 - 2) / 2 &
+ + (ps3 - 1) * (ps3 - 2) / 2 &
+ + (ps4 - 1) * (ps4 - 2) / 2 &
+ + (order - 1) * (order - 2) * (order - 3) / 6_I4B
+
+dim3 = 3
+
+ALLOCATE (ans0(dim1, dim2, dim3 + 1), lambda(4, dim1))
+
+CALL BarycentricCoordTetrahedron_(xin=xij, refTetrahedron=refTetrahedron, &
+ ans=lambda, nrow=indx(1), ncol=indx(2))
+
+ans0 = BarycentricHeirarchicalBasisGradient_Tetrahedron(lambda=lambda, &
+ order=order, pe1=pe1, pe2=pe2, pe3=pe3, pe4=pe4, pe5=pe5, pe6=pe6, &
+ ps1=ps1, ps2=ps2, ps3=ps3, ps4=ps4)
+
+ans(1:dim1, 1:dim2, 1) = ans0(:, :, 2) - ans0(:, :, 1)
+ans(1:dim1, 1:dim2, 2) = ans0(:, :, 3) - ans0(:, :, 1)
+ans(1:dim1, 1:dim2, 3) = ans0(:, :, 4) - ans0(:, :, 1)
+
+name = UpperCase(refTetrahedron(1:1))
+IF (name .EQ. "B") THEN
+ ans(1:dim1, 1:dim2, 1:dim3) = 0.5_DFP * ans(1:dim1, 1:dim2, 1:dim3)
+END IF
+
+DEALLOCATE (ans0, lambda)
+END PROCEDURE HeirarchicalBasisGradient_Tetrahedron1_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Tetrahedron
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE HeirarchicalBasisGradient_Tetrahedron2
ans = HeirarchicalBasisGradient_Tetrahedron1( &
& order=order, &
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
index df48713f1..b516b00d9 100644
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
+++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
@@ -23,52 +23,110 @@
CONTAINS
!----------------------------------------------------------------------------
-! BarycentricVertexBasis_Triangle
+! BarycentricVertexBasis_Triangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE BarycentricVertexBasis_Triangle
-INTEGER(I4B) :: a(2)
-a = SHAPE(lambda)
-ans(1:a(2), 1:a(1)) = TRANSPOSE(lambda)
-END PROCEDURE BarycentricVertexBasis_Triangle
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Returns the vertex basis functions on reference Triangle
+
+PURE SUBROUTINE BarycentricVertexBasis_Triangle(lambda, ans, nrow, &
+ ncol)
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentrix coords
+ !! number of rows = 3 corresponding to three coordinates
+ !! number of columns = number of points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! REAL(DFP) :: ans(SIZE(lambda, 2), 3)
+ !! ans(:,v1) basis function of vertex v1 at all points
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = size(lambda, 2)
+ !! ncol = 3
+
+ !! internal variables
+ INTEGER(I4B) :: ii, jj
+
+ nrow = SIZE(lambda, 2)
+ ncol = SIZE(lambda, 1)
+
+ DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = lambda(jj, ii)
+ END DO
+
+END SUBROUTINE BarycentricVertexBasis_Triangle
!----------------------------------------------------------------------------
! VertexBasis_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE VertexBasis_Triangle
+INTEGER(I4B) :: nrow, ncol
REAL(DFP) :: lambda(3, SIZE(xij, 2))
CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans)
+CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE VertexBasis_Triangle
!----------------------------------------------------------------------------
-! BarycentricEdgeBasis_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, ii, jj
-
-tPoints = SIZE(lambda, 2)
-maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2)
+!> 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
-DO CONCURRENT(ii=1:tpoints)
- ! edge 1 -> 2
- d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
- ! edge 2 -> 3
- d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii)
- ! edge 3 -> 1
- d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii)
-END DO
+PURE SUBROUTINE BarycentricEdgeBasis_Triangle(pe1, pe2, pe3, lambda, ans, &
+ nrow, ncol)
+ 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
+ !! Number of rows in lambda is equal to three corresponding to
+ !! three coordinates
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow=SIZE(lambda, 2)
+ !! ncol=pe1 + pe2 + pe3 - 3
+
+ INTEGER(I4B), PARAMETER :: orient = 1
+ REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
+ ! REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2))
+ REAL(DFP), ALLOCATABLE :: phi(:, :)
+
+ INTEGER(I4B) :: maxP, ii
+
+ nrow = SIZE(lambda, 2)
+ ! ncol = pe1 + pe2 + pe3 - 3
+ maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2)
+
+ ALLOCATE (phi(1:3 * nrow, 0:maxP))
+
+ DO CONCURRENT(ii=1:nrow)
+ ! edge 1 -> 2
+ d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
+ ! edge 2 -> 3
+ d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii)
+ ! edge 3 -> 1
+ d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii)
+ END DO
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=ii, ncol=jj)
+ CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=nrow, ncol=ncol)
-CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
- lambda=lambda, phi=phi, ans=ans)
+ CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
+ lambda=lambda, phi=phi, ans=ans, nrow=nrow, ncol=ncol, &
+ edgeOrient1=orient, edgeOrient2=orient, edgeOrient3=orient)
-END PROCEDURE BarycentricEdgeBasis_Triangle
+END SUBROUTINE BarycentricEdgeBasis_Triangle
!----------------------------------------------------------------------------
!
@@ -80,55 +138,80 @@
! (internal only)
MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, &
- lambda, phi, ans)
+ lambda, phi, ans, nrow, ncol, edgeOrient1, edgeOrient2, edgeOrient3)
INTEGER(I4B), INTENT(IN) :: pe1
- !! order on edge (e1)
+ !! order on edge (e1)
INTEGER(I4B), INTENT(IN) :: pe2
- !! order on edge (e2)
+ !! order on edge (e2)
INTEGER(I4B), INTENT(IN) :: pe3
- !! order on edge (e3)
+ !! 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
+ !! 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
+ !! lobatto kernel values
+ !! size(phi1, 1) = 3*number of points
+ !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
+ !! (lambda2-lambda1),
+ !! (lambda3-lambda2),
+ !! (lambda1-lambda3)
REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP), INTENT(INOUT) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3)
+ !! ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = size(lambda, 2)
+ !! ncol = pe1 + pe2 + pe3 - 3
+ INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3
- INTEGER(I4B) :: tPoints, a, ii
- REAL(DFP) :: temp(SIZE(lambda, 2))
- !FIXME: Remove this temp, I want no allocation in this routine
+ !! Internal variables
+ INTEGER(I4B) :: a, ii, jj
+ REAL(DFP) :: temp, areal, o1, o2, o3
- ans = 0.0_DFP
- tPoints = SIZE(lambda, 2)
- a = 0
+ nrow = SIZE(lambda, 2)
+ ! tPoints = SIZE(lambda, 2)
+ ncol = pe1 + pe2 + pe3 - 3
+
+ o1 = REAL(edgeOrient1, kind=DFP)
+ o2 = REAL(edgeOrient2, kind=DFP)
+ o3 = REAL(edgeOrient3, kind=DFP)
- !FIXME: Make these loop parallel
+ ! ans = 0.0_DFP
+ a = 0
! edge(1) = 1 -> 2
- temp = lambda(1, :) * lambda(2, :)
DO ii = 1, pe1 - 1
- ans(:, a + ii) = temp * phi(1:tPoints, ii - 1)
+ areal = o1**(ii + 1)
+ ! ans(1:nrow, a + ii) = areal * temp * phi(1:nrow, ii - 1)
+
+ DO jj = 1, nrow
+ temp = lambda(1, jj) * lambda(2, jj) * areal
+ ans(jj, a + ii) = temp * phi(jj, ii - 1)
+ END DO
END DO
! edge(2) = 2 -> 3
a = pe1 - 1
- temp = lambda(2, :) * lambda(3, :)
+
DO ii = 1, pe2 - 1
- ans(:, a + ii) = temp &
- * phi(1 + tPoints:2 * tPoints, ii - 1)
+ areal = o2**(ii + 1)
+
+ DO jj = 1, nrow
+ temp = lambda(2, jj) * lambda(3, jj) * areal
+ ans(jj, a + ii) = temp * phi(jj + nrow, ii - 1)
+ END DO
+
END DO
! edge(3) = 3 -> 1
a = pe1 - 1 + pe2 - 1
- temp = lambda(3, :) * lambda(1, :)
+
DO ii = 1, pe3 - 1
- ans(:, a + ii) = temp &
- * phi(1 + 2 * tPoints:3 * tPoints, ii - 1)
+ areal = o3**(ii + 1)
+
+ DO jj = 1, nrow
+ temp = areal * lambda(3, jj) * lambda(1, jj)
+ ans(jj, a + ii) = temp * phi(jj + 2 * nrow, ii - 1)
+ END DO
END DO
END SUBROUTINE BarycentricEdgeBasis_Triangle2
@@ -138,38 +221,119 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle2
MODULE PROCEDURE EdgeBasis_Triangle
REAL(DFP) :: lambda(3, SIZE(xij, 2))
+INTEGER(I4B) :: nrow, ncol
+
CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
CALL BarycentricEdgeBasis_Triangle(lambda=lambda, ans=ans, pe1=pe1, &
- pe2=pe2, pe3=pe3)
+ pe2=pe2, pe3=pe3, nrow=nrow, ncol=ncol)
END PROCEDURE EdgeBasis_Triangle
!----------------------------------------------------------------------------
-! BarycentricEdgeBasis_Triangle
+! BarycentricCellBasis_Triangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE BarycentricCellBasis_Triangle
-REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
-REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2)
-INTEGER(I4B) :: maxP, tPoints, ii, nrow, ncol
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Returns the Cell basis functions on reference Triangle
-tPoints = SIZE(lambda, 2)
-maxP = order - 2
+PURE SUBROUTINE BarycentricCellBasis_Triangle(order, lambda, ans, nrow, ncol)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order in this cell, it should be greater than 2
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentrix coords
+ !! number of rows = 3 corresponding to three coordinates
+ !! number of columns = number of points
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ ! ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = INT((order - 1) * (order - 2) / 2)
+
+ !! internal variables
+ REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
+ REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), 0:order - 2)
+ INTEGER(I4B) :: maxP, ii
+ INTEGER(I4B), PARAMETER :: faceOrient(2) = [0, 1]
+
+ nrow = SIZE(lambda, 2)
+ maxP = order - 2
+
+ DO CONCURRENT(ii=1:nrow)
+ ! Cell 1 -> 2
+ d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
+ ! Cell 2 -> 3
+ d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii)
+ ! Cell 3 -> 1
+ d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii)
+ END DO
-DO CONCURRENT(ii=1:tpoints)
- ! Cell 1 -> 2
- d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
- ! Cell 2 -> 3
- d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii)
- ! Cell 3 -> 1
- d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii)
-END DO
+ CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+ CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, &
+ ans=ans, nrow=nrow, ncol=ncol, faceOrient=faceOrient)
+
+END SUBROUTINE BarycentricCellBasis_Triangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MakeFaceCase_Triangle(faceOrient, nrow, id, indx)
+ INTEGER(I4B), INTENT(IN) :: faceOrient(2)
+ INTEGER(I4B), INTENT(IN) :: nrow
+ INTEGER(I4B), INTENT(OUT) :: id
+ INTEGER(I4B), INTENT(OUT) :: indx(2, 2)
+ !! main program
+
+ IF (faceOrient(2) .LT. 0) THEN
+ SELECT CASE (faceOrient(1))
+ CASE (1)
+ id = 2
+ indx(1, 1) = 2
+ indx(1, 2) = 1
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=ans, nrow=nrow, ncol=ncol)
+ CASE (2)
+ id = 3
+ indx(1, 1) = 3
+ indx(1, 2) = 2
-CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, &
- ans=ans)
+ CASE DEFAULT
+ id = 1
+ indx(1, 1) = 1
+ indx(1, 2) = 3
-END PROCEDURE BarycentricCellBasis_Triangle
+ END SELECT
+
+ ELSE
+
+ SELECT CASE (faceOrient(1))
+ CASE (1)
+ id = 5
+ indx(1, 1) = 2
+ indx(1, 2) = 3
+
+ CASE (2)
+ id = 6
+ indx(1, 1) = 1
+ indx(1, 2) = 2
+
+ CASE default
+ id = 4
+ indx(1, 1) = 3
+ indx(1, 2) = 1
+
+ END SELECT
+
+ END IF
+
+ indx(1, 1) = nrow * (indx(1, 1) - 1) + 1
+ indx(2, 1) = indx(1, 1) + nrow - 1
+
+ indx(1, 2) = nrow * (indx(1, 2) - 1) + 1
+ indx(2, 2) = indx(1, 2) + nrow - 1
+
+END SUBROUTINE MakeFaceCase_Triangle
!----------------------------------------------------------------------------
! BarycentricCellBasis_Triangle
@@ -179,36 +343,58 @@ END SUBROUTINE BarycentricEdgeBasis_Triangle2
! date: 28 Oct 2022
! summary: Eval basis in the cell of reference triangle (internal only)
-PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans)
+PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans, &
+ nrow, ncol, faceOrient)
INTEGER(I4B), INTENT(IN) :: order
- !! order in the cell of triangle, it should be greater than 2
+ !! order in the cell of triangle, it should be greater than 2
REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation in terms of barcentric coordinates
+ !! point of evaluation in terms of barcentric coordinates
REAL(DFP), INTENT(IN) :: phi(1:, 0:)
- !! lobatto kernel values
- !! size(phi1, 1) = 3*number of points
- !! (lambda2-lambda1),
- !! (lambda3-lambda2),
- !! (lambda1-lambda3)
- !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
+ !! lobatto kernel values
+ !! size(phi1, 1) = 3*number of points
+ !! (lambda2-lambda1),
+ !! (lambda3-lambda2),
+ !! (lambda1-lambda3)
+ !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
REAL(DFP), INTENT(INOUT) :: ans(:, :)
! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = size(lambda, 2)
+ !! ncol = INT((order - 1) * (order - 2) / 2)
+ INTEGER(I4B), INTENT(IN) :: faceOrient(2)
- INTEGER(I4B) :: tp, k1, k2, cnt
- REAL(DFP) :: temp(SIZE(lambda, 2))
- !! FIXME: Remove this temp from there, no allocation is our goal
+ INTEGER(I4B) :: k1, k2, cnt, id, indx(2, 2), aint, bint, ii
+ REAL(DFP) :: temp, areal, breal, o1
+
+ nrow = SIZE(lambda, 2)
+ ncol = INT((order - 1) * (order - 2) / 2)
- tp = SIZE(lambda, 2)
- temp = lambda(1, :) * lambda(2, :) * lambda(3, :)
cnt = 0
- ! FIXME: Make this loop parallel
+ CALL MakeFaceCase_Triangle(faceOrient=faceOrient, nrow=nrow, id=id, &
+ indx=indx)
+
+ aint = indx(1, 1) - 1
+ bint = indx(1, 2) - 1
+
+ o1 = REAL(faceOrient(2), kind=DFP)
DO k1 = 1, order - 2
+ areal = o1**(k1 + 1)
+
DO k2 = 1, order - 1 - k1
+ breal = o1**(k2 + 1)
+ breal = breal * areal
+
cnt = cnt + 1
- ans(:, cnt) = temp * phi(1:tp, k1 - 1) * &
- & phi(1 + 2 * tp:3 * tp, k2 - 1)
+
+ DO ii = 1, nrow
+
+ temp = lambda(1, ii) * lambda(2, ii) * lambda(3, ii) * breal
+
+ ans(ii, cnt) = temp * phi(aint + ii, k1 - 1) * phi(bint + ii, k2 - 1)
+ END DO
+
END DO
END DO
@@ -220,72 +406,97 @@ END SUBROUTINE BarycentricCellBasis_Triangle2
MODULE PROCEDURE CellBasis_Triangle
REAL(DFP) :: lambda(3, SIZE(xij, 2))
+INTEGER(I4B) :: nrow, ncol
CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order)
+CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order, &
+ nrow=nrow, ncol=ncol)
END PROCEDURE CellBasis_Triangle
!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasis_Triangle
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle1
-INTEGER(I4B) :: a, b, ii
-INTEGER(I4B) :: maxP
-REAL(DFP) :: phi(1:3 * SIZE(lambda, 2), &
- 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2))
-REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
-LOGICAL(LGT) :: isok
-
-nrow = SIZE(lambda, 2)
-ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
-
-maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)
-
-DO CONCURRENT(ii=1:nrow)
- ! edge 1 -> 2
- d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
- ! edge 2 -> 3
- d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii)
- ! edge 3 -> 1
- d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii)
-END DO
+MODULE PURE SUBROUTINE BarycentricHeirarchicalBasis_Triangle(order, &
+ pe1, pe2, pe3, lambda, refTriangle, edgeOrient1, edgeOrient2, &
+ edgeOrient3, faceOrient, ans, nrow, ncol)
+ 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) :: lambda(:, :)
+ !! Barycenteric coordinates
+ !! number of rows = 3
+ !! number of cols = number of points
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! reference triangle, "BIUNIT", "UNIT"
+ INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3
+ !! edge orientation 1 or -1
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:)
+ !! face orientation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !!
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(lambda, 2)
+ !! ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
+
+ !! Internal variables
+ INTEGER(I4B) :: ii, maxP, indx(3)
+ REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
+ REAL(DFP), ALLOCATABLE :: phi(:, :)
+ LOGICAL(LGT) :: isok
+
+ nrow = SIZE(lambda, 2)
+ ! ncol = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
+ ncol = 0
+
+ maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)
+
+ ALLOCATE (phi(1:3 * nrow, 0:maxP))
+
+ DO CONCURRENT(ii=1:nrow)
+ ! edge 1 -> 2
+ d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
+ ! edge 2 -> 3
+ d_lambda(ii + nrow) = lambda(3, ii) - lambda(2, ii)
+ ! edge 3 -> 1
+ d_lambda(ii + 2 * nrow) = lambda(1, ii) - lambda(3, ii)
+ END DO
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
+ CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=indx(1), &
+ ncol=indx(2))
-! Vertex basis function
-ans = 0.0_DFP
-CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3))
+ !! Vertex basis function
+ CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3), &
+ nrow=indx(1), ncol=indx(2))
-! Edge basis function
-b = 3
+ !! Edge basis function
+ ncol = ncol + indx(2)
-isok = ANY([pe1, pe2, pe3] .GE. 2_I4B)
-IF (isok) THEN
- a = b + 1
- b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2
- CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
- lambda=lambda, phi=phi, ans=ans(:, a:b))
-END IF
+ isok = ANY([pe1, pe2, pe3] .GE. 2_I4B)
+ IF (isok) THEN
+ CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
+ lambda=lambda, phi=phi, ans=ans(:, ncol + 1:), nrow=indx(1), &
+ ncol=indx(2), edgeOrient1=edgeOrient1, edgeOrient2=edgeOrient2, &
+ edgeOrient3=edgeOrient3)
-! Cell basis function
-IF (order .GT. 2_I4B) THEN
- a = b + 1
- b = a - 1 + INT((order - 1) * (order - 2) / 2)
- CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, &
- ans=ans(:, a:b))
-END IF
+ ncol = ncol + indx(2)
+ END IF
-END PROCEDURE BarycentricHeirarchicalBasis_Triangle1
+ !! Cell basis function
+ isok = order .GT. 2_I4B
+ IF (isok) THEN
+ CALL BarycentricCellBasis_Triangle2(order=order, lambda=lambda, phi=phi, &
+ ans=ans(:, ncol + 1:), nrow=indx(1), ncol=indx(2), faceOrient=faceOrient)
+ ncol = ncol + indx(2)
+ END IF
-!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
+ DEALLOCATE (phi)
-MODULE PROCEDURE BarycentricHeirarchicalBasis_Triangle2
-CALL BarycentricHeirarchicalBasis_Triangle1(order=order, pe1=order, &
- pe2=order, pe3=order, lambda=lambda, &
- refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
-END PROCEDURE BarycentricHeirarchicalBasis_Triangle2
+END SUBROUTINE BarycentricHeirarchicalBasis_Triangle
!----------------------------------------------------------------------------
! HeirarchicalBasis_Triangle
@@ -302,11 +513,11 @@ END SUBROUTINE BarycentricCellBasis_Triangle2
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasis_Triangle1_
-REAL(DFP) :: lambda(3, SIZE(xij, 2))
-CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricHeirarchicalBasis_Triangle(order=order, pe1=pe1, pe2=pe2, &
- pe3=pe3, lambda=lambda, refTriangle=refTriangle, ans=ans, nrow=nrow, &
- ncol=ncol)
+INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [0, 1]
+CALL HeirarchicalBasis_Triangle3_(order=order, pe1=pe1, pe2=pe2, pe3=pe3, &
+ xij=xij, refTriangle=refTriangle, edgeOrient1=orient, &
+ edgeOrient2=orient, edgeOrient3=orient, faceOrient=faceOrient, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE HeirarchicalBasis_Triangle1_
!----------------------------------------------------------------------------
@@ -324,58 +535,175 @@ END SUBROUTINE BarycentricCellBasis_Triangle2
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasis_Triangle2_
-REAL(DFP) :: lambda(3, SIZE(xij, 2))
-CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricHeirarchicalBasis_Triangle(order=order, lambda=lambda, &
- refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
+INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [0, 1]
+CALL HeirarchicalBasis_Triangle3_(order=order, pe1=order, pe2=order, pe3=order, &
+ xij=xij, refTriangle=refTriangle, edgeOrient1=orient, &
+ edgeOrient2=orient, edgeOrient3=orient, faceOrient=faceOrient, &
+ ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE HeirarchicalBasis_Triangle2_
!----------------------------------------------------------------------------
-! BarycentricVertexBasisGradient_Triangle
+! HeirarchicalBasis_Triangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE BarycentricVertexBasisGradient_Triangle
-INTEGER(I4B) :: ii, tp
-
-tp = SIZE(lambda, 2)
-ans(1:tp, 1:3, 1:3) = 0.0_DFP
-DO CONCURRENT(ii=1:3)
- ans(1:tp, ii, ii) = 1.0_DFP
-END DO
-
-END PROCEDURE BarycentricVertexBasisGradient_Triangle
+MODULE PROCEDURE HeirarchicalBasis_Triangle3_
+REAL(DFP) :: lambda(3, SIZE(xij, 2))
+CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
+CALL BarycentricHeirarchicalBasis_Triangle(order=order, pe1=pe1, pe2=pe2, &
+ pe3=pe3, lambda=lambda, refTriangle=refTriangle, edgeOrient1=edgeOrient1, &
+ edgeOrient2=edgeOrient2, edgeOrient3=edgeOrient3, faceOrient=faceOrient, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Triangle3_
!----------------------------------------------------------------------------
-! BarycentricEdgeBasisGradient_Triangle2
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE BarycentricEdgeBasisGradient_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))
-REAL(DFP) :: gradientPhi(1:3 * SIZE(lambda, 2), 0:MAX(pe1 - 2, pe2 - 2, pe3 - 2))
-INTEGER(I4B) :: maxP, tPoints, ii, a, b
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-04-21
+! summary: Evaluate the gradient of the edge basis on triangle
+! using barycentric coordinate
+
+PURE SUBROUTINE BarycentricVertexBasisGradient_Triangle(lambda, ans, &
+ dim1, dim2, dim3)
+ 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(INOUT) :: ans(:, :, :)
+ !! ans(SIZE(lambda, 2), 3, 3)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(lambda, 2)
+ !! dim2 = 3
+ !! dim3 = 3
-tPoints = SIZE(lambda, 2)
-maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2)
+ INTEGER(I4B) :: ii
-DO CONCURRENT(ii=1:tpoints)
- ! edge 1 -> 2
- d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
- ! edge 2 -> 3
- d_lambda(ii + tPoints) = lambda(3, ii) - lambda(2, ii)
- ! edge 3 -> 1
- d_lambda(ii + 2 * tPoints) = lambda(1, ii) - lambda(3, ii)
-END DO
+ dim1 = SIZE(lambda, 2)
+ dim2 = 3
+ dim3 = 3
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
+ ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+ DO CONCURRENT(ii=1:dim2)
+ ans(1:dim1, ii, ii) = 1.0_DFP
+ END DO
+END SUBROUTINE BarycentricVertexBasisGradient_Triangle
-CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
- nrow=a, ncol=b)
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
- lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans)
+!> author: Shion Shimizu
+! date: 2024-04-21
+! summary: Evaluate the gradient of the edge basis on triangle
+! using barycentric coordinate
+
+! PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle(pe1, pe2, pe3, lambda, &
+! ans, dim1, dim2, dim3)
+! 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(INOUT) :: ans(:, :, :)
+! !! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3)
+! INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+! !! dim1=SIZE(lambda, 2)
+! !! dim2=pe1 + pe2 + pe3 - 3
+! !! dim3=3
+!
+! REAL(DFP) :: d_lambda(3 * SIZE(lambda, 2))
+! REAL(DFP), ALLOCATABLE :: gradientPhi(:, :), phi(:, :)
+! INTEGER(I4B) :: maxP, ii
+!
+! dim1 = SIZE(lambda, 2)
+! ! dim2 = pe1 + pe2 + pe3 - 3
+! ! dim3 = 3
+!
+! maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2)
+!
+! ALLOCATE (gradientPhi(1:3 * dim1, 0:maxP), phi(1:3 * dim1, 0:maxP))
+!
+! DO CONCURRENT(ii=1:dim1)
+! ! edge 1 -> 2
+! d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
+! ! edge 2 -> 3
+! d_lambda(ii + dim1) = lambda(3, ii) - lambda(2, ii)
+! ! edge 3 -> 1
+! d_lambda(ii + 2 * dim1) = lambda(1, ii) - lambda(3, ii)
+! END DO
+!
+! CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=dim1, ncol=dim2)
+!
+! CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
+! nrow=dim1, ncol=dim2)
+!
+! CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
+! lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans, &
+! dim1=dim1, dim2=dim2, dim3=dim3)
+!
+! DEALLOCATE (gradientPhi, phi)
+!
+! END SUBROUTINE BarycentricEdgeBasisGradient_Triangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-END PROCEDURE BarycentricEdgeBasisGradient_Triangle
+!> author: Shion Shimizu
+! date: 2024-04-21
+! summary: Evaluate the gradient of the edge basis on triangle
+! using barycentric coordinate
+!
+! PURE SUBROUTINE BarycentricCellBasisGradient_Triangle(order, lambda, ans, &
+! dim1, dim2, dim3)
+! INTEGER(I4B), INTENT(IN) :: order
+! !! order on Cell (e1)
+! 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(INOUT) :: ans(:, :, :)
+! ! REAL(DFP) :: ans(SIZE(lambda, 2), 3*order - 3, 3)
+! INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+! !! dim1=SIZE(lambda, 2)
+! !! dim2=3*order - 3
+! !! dim3=3
+!
+! !! internal variables
+! INTEGER(I4B) :: a, b, ii, maxP, tp
+! REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:)
+!
+! dim1 = SIZE(lambda, 2)
+! maxP = order - 2
+!
+! a = 3 * dim1; b = maxP
+! ALLOCATE (phi(a, b), gradientPhi(a, b), d_lambda(a))
+!
+! DO CONCURRENT(ii=1:dim1)
+! ! edge 1 -> 2
+! d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
+! ! edge 2 -> 3
+! d_lambda(ii + dim1) = lambda(3, ii) - lambda(2, ii)
+! ! edge 3 -> 1
+! d_lambda(ii + 2 * dim1) = lambda(1, ii) - lambda(3, ii)
+! END DO
+!
+! CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=dim1, ncol=dim2)
+!
+! CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
+! nrow=dim1, ncol=dim2)
+!
+! CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, &
+! phi=phi, gradientPhi=gradientPhi, ans=ans, dim1=dim1, dim2=dim2, &
+! dim3=dim3, faceOrient=faceOrient)
+!
+! END SUBROUTINE BarycentricCellBasisGradient_Triangle
!----------------------------------------------------------------------------
!
@@ -387,111 +715,132 @@ END SUBROUTINE BarycentricCellBasis_Triangle2
! using barycentric coordinate
PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle2(pe1, pe2, pe3, &
- lambda, phi, gradientPhi, ans)
+ lambda, phi, gradientPhi, ans, dim1, dim2, dim3, &
+ edgeOrient1, edgeOrient2, edgeOrient3)
INTEGER(I4B), INTENT(IN) :: pe1
- !! order on edge (e1)
+ !! order on edge (e1)
INTEGER(I4B), INTENT(IN) :: pe2
- !! order on edge (e2)
+ !! order on edge (e2)
INTEGER(I4B), INTENT(IN) :: pe3
- !! order on edge (e3)
+ !! 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
+ !! 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
+ !! lobatto kernel values
+ !! size(phi1, 1) = 3*number of points
+ !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
+ !! (lambda2-lambda1)
+ !! (lambda3-lambda2)
+ !! (lambda1-lambda3)
REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:)
- !! gradients of lobatto kernel functions
+ !! gradients of lobatto kernel functions
REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3)
-
- INTEGER(I4B) :: tp, a, ii
- REAL(DFP) :: temp(SIZE(lambda, 2))
- ! FIXME: Remove this temp
-
- tp = SIZE(lambda, 2)
-
- !FIXME: Make these loop parallel
+ !! REAL(DFP) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3, 3)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1=SIZE(lambda, 2)
+ !! dim2=pe1 + pe2 + pe3 - 3
+ !! dim3=3
+ INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3
+ !! edge orientation
+
+ !! Internal variables
+ INTEGER(I4B) :: a, ii, jj
+ REAL(DFP) :: rr(10), o1, o2, o3
+
+ dim1 = SIZE(lambda, 2)
+ dim2 = pe1 + pe2 + pe3 - 3
+ dim3 = 3
+
+ o1 = REAL(edgeOrient1, kind=DFP)
+ o2 = REAL(edgeOrient2, kind=DFP)
+ o3 = REAL(edgeOrient3, kind=DFP)
a = 0
! edge(1) = 1 -> 2
- temp = lambda(1, :) * lambda(2, :)
+
DO ii = 1, pe1 - 1
- ans(1:tp, a + ii, 1) = lambda(2, :) * phi(1:tp, ii - 1) - &
- temp * gradientPhi(1:tp, ii - 1)
- ans(1:tp, a + ii, 2) = lambda(1, :) * phi(1:tp, ii - 1) + &
- temp * gradientPhi(1:tp, ii - 1)
- ans(1:tp, a + ii, 3) = 0.0_DFP
+ rr(1) = o1**(ii + 1)
+ rr(2) = o1**(ii)
+
+ DO jj = 1, dim1
+ rr(3) = lambda(1, jj) * lambda(2, jj)
+
+ rr(4) = rr(1) * lambda(2, jj) * phi(jj, ii - 1)
+
+ rr(5) = rr(2) * rr(3) * gradientPhi(jj, ii - 1)
+
+ ans(jj, a + ii, 1) = rr(4) - rr(5)
+
+ rr(4) = rr(1) * lambda(1, jj) * phi(jj, ii - 1)
+
+ rr(5) = rr(2) * rr(3) * gradientPhi(jj, ii - 1)
+
+ ans(jj, a + ii, 2) = rr(4) + rr(5)
+
+ ans(jj, a + ii, 3) = 0.0_DFP
+
+ END DO
+
END DO
! edge(2) = 2 -> 3
a = pe1 - 1
- temp = lambda(2, :) * lambda(3, :)
+
DO ii = 1, pe2 - 1
- ans(1:tp, a + ii, 1) = 0.0_DFP
+ rr(1) = o2**(ii + 1)
+ rr(2) = o2**(ii)
+
+ DO jj = 1, dim1
+ rr(3) = lambda(2, jj) * lambda(3, jj)
+
+ ans(jj, a + ii, 1) = 0.0_DFP
+
+ rr(4) = rr(1) * lambda(3, jj) * phi(jj + dim1, ii - 1)
+ rr(5) = rr(2) * rr(3) * gradientPhi(jj + dim1, ii - 1)
- ans(1:tp, a + ii, 2) = lambda(3, :) * &
- phi(1 + tp:2 * tp, ii - 1) - &
- temp * gradientPhi(1 + tp:2 * tp, ii - 1)
+ ans(jj, a + ii, 2) = rr(4) - rr(5)
+
+ rr(4) = rr(1) * lambda(2, jj) * phi(jj + dim1, ii - 1)
+ rr(5) = rr(2) * rr(3) * gradientPhi(jj + dim1, ii - 1)
+
+ ans(jj, a + ii, 3) = rr(4) + rr(5)
+
+ END DO
- ans(1:tp, a + ii, 3) = lambda(2, :) * &
- phi(1 + tp:2 * tp, ii - 1) + &
- temp * gradientPhi(1 + tp:2 * tp, ii - 1)
END DO
! edge(3) = 3 -> 1
a = pe1 - 1 + pe2 - 1
- temp = lambda(3, :) * lambda(1, :)
+
DO ii = 1, pe3 - 1
- ans(1:tp, a + ii, 1) = lambda(3, :) * &
- phi(1 + 2 * tp:3 * tp, ii - 1) + &
- temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1)
+ rr(1) = o3**(ii + 1)
+ rr(2) = o3**(ii)
- ans(1:tp, a + ii, 2) = 0.0_DFP
+ DO jj = 1, dim1
+ rr(3) = lambda(3, jj) * lambda(1, jj)
- ans(1:tp, a + ii, 3) = lambda(1, :) * &
- phi(1 + 2 * tp:3 * tp, ii - 1) - &
- temp * gradientPhi(1 + 2 * tp:3 * tp, ii - 1)
- END DO
-END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2
+ rr(4) = rr(1) * lambda(3, jj) * phi(jj + 2 * dim1, ii - 1)
+ rr(5) = rr(2) * rr(3) * gradientPhi(jj + 2 * dim1, ii - 1)
-!----------------------------------------------------------------------------
-! BarycentricVertexBasisGradient_Triangle
-!----------------------------------------------------------------------------
+ ans(jj, a + ii, 1) = rr(4) + rr(5)
-MODULE PROCEDURE BarycentricCellBasisGradient_Triangle
-INTEGER(I4B) :: a, b, ii, maxP, tp
-REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:)
+ ans(jj, a + ii, 2) = 0.0_DFP
-tp = SIZE(lambda, 2)
-maxP = order - 2
+ rr(4) = rr(1) * lambda(1, jj) * phi(jj + 2 * dim1, ii - 1)
+ rr(5) = rr(2) * rr(3) * gradientPhi(jj + 2 * dim1, ii - 1)
-a = 3 * tp; b = maxP
-ALLOCATE (phi(a, b), gradientPhi(a, b), d_lambda(a))
-
-DO CONCURRENT(ii=1:tp)
- ! edge 1 -> 2
- d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
- ! edge 2 -> 3
- d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii)
- ! edge 3 -> 1
- d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii)
-END DO
+ ans(jj, a + ii, 3) = rr(4) - rr(5)
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
+ END DO
-CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
- nrow=a, ncol=b)
+ END DO
-CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, &
- phi=phi, gradientPhi=gradientPhi, ans=ans)
-END PROCEDURE BarycentricCellBasisGradient_Triangle
+END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2
!----------------------------------------------------------------------------
-! BarycentricCellBasisGradient_Triangle
+! BarycentricCellBasisGradient_Triangle2
!----------------------------------------------------------------------------
!> author: Shion Shimizu
@@ -499,53 +848,71 @@ END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2
! summary: Evaluate the gradient of the cell basis on triangle
PURE SUBROUTINE BarycentricCellBasisGradient_Triangle2(order, lambda, phi, &
- gradientPhi, ans)
+ gradientPhi, ans, dim1, dim2, dim3, faceOrient)
INTEGER(I4B), INTENT(IN) :: order
- !! order in the cell of triangle, it should be greater than 2
+ !! order in the cell of triangle, it should be greater than 2
REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation
+ !! 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
+ !! 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), INTENT(IN) :: gradientPhi(1:, 0:)
- !! gradients of lobatto kernel functions
+ !! gradients of lobatto kernel functions
REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2), 3)
+ !! gradient
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! dim1 = SIZE(lambda, 2)
+ !! dim2 = INT((order - 1) * (order - 2) / 2)
+ !! dim3 = 3
+ INTEGER(I4B), INTENT(IN) :: faceOrient(2)
+ !! face orientation
! internal variables
- INTEGER(I4B) :: tPoints, k1, k2, cnt
- REAL(DFP) :: temp1(SIZE(lambda, 2)), temp2(SIZE(lambda, 2))
- REAL(DFP) :: temp3(SIZE(lambda, 2)), temp4(SIZE(lambda, 2))
+ INTEGER(I4B) :: k1, k2, cnt, ii
+ REAL(DFP) :: rr(10)
- ! FIXME: Remove these temps
+ dim1 = SIZE(lambda, 2)
+ dim2 = INT((order - 1) * (order - 2) / 2)
+ dim3 = 3
- tPoints = SIZE(lambda, 2)
- temp1 = lambda(1, :) * lambda(2, :) * lambda(3, :)
- temp2 = lambda(2, :) * lambda(3, :)
- temp3 = lambda(1, :) * lambda(3, :)
- temp4 = lambda(1, :) * lambda(2, :)
cnt = 0
- ! FIXME: make these loop parallel
-
DO k1 = 1, order - 2
DO k2 = 1, order - 1 - k1
+
cnt = cnt + 1
- ans(:, cnt, 1) = temp2 * phi(1:tPoints, k1 - 1) * &
- phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - &
- temp1 * (gradientPhi(1:tPoints, k1 - 1) * &
- phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - &
- phi(1:tPoints, k1 - 1) * &
- gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1))
- ans(:, cnt, 2) = (temp3 * phi(1:tPoints, k1 - 1) + &
- temp1 * gradientPhi(1:tPoints, k1 - 1)) * &
- phi(1 + 2 * tPoints:3 * tPoints, k2 - 1)
- ans(:, cnt, 3) = (temp4 * phi(1 + 2 * tPoints:3 * tPoints, k2 - 1) - &
- temp1 * gradientPhi(1 + 2 * tPoints:3 * tPoints, k2 - 1)) * &
- phi(1:tPoints, k1 - 1)
+
+ DO ii = 1, dim1
+
+ rr(1) = lambda(1, ii) * lambda(2, ii) * lambda(3, ii)
+ rr(2) = lambda(2, ii) * lambda(3, ii)
+ rr(3) = lambda(1, ii) * lambda(3, ii)
+ rr(4) = lambda(1, ii) * lambda(2, ii)
+
+ rr(5) = rr(2) * phi(ii, k1 - 1) * phi(ii + 2 * dim1, k2 - 1)
+ rr(6) = phi(ii + 2 * dim1, k2 - 1) * gradientPhi(ii, k1 - 1)
+ rr(7) = phi(ii, k1 - 1) * gradientPhi(ii + 2 * dim1, k2 - 1)
+ rr(8) = rr(6) - rr(7)
+ ans(ii, cnt, 1) = rr(5) - rr(1) * rr(8)
+
+ rr(5) = rr(3) * phi(ii, k1 - 1)
+ rr(6) = rr(1) * gradientPhi(ii, k1 - 1)
+ rr(7) = rr(5) + rr(6)
+ rr(8) = phi(ii + 2 * dim1, k2 - 1)
+ ans(ii, cnt, 2) = rr(7) * rr(8)
+
+ rr(5) = rr(4) * phi(ii + 2 * dim1, k2 - 1)
+ rr(6) = rr(1) * gradientPhi(ii + 2 * dim1, k2 - 1)
+ rr(7) = rr(5) - rr(6)
+ rr(8) = phi(ii, k1 - 1)
+ ans(ii, cnt, 3) = rr(7) * rr(8)
+
+ END DO
+
END DO
+
END DO
END SUBROUTINE BarycentricCellBasisGradient_Triangle2
@@ -553,58 +920,93 @@ END SUBROUTINE BarycentricCellBasisGradient_Triangle2
! BarycentricHeirarchicalBasis_Triangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1
-INTEGER(I4B) :: a, b, ii, maxP, tp
-REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:)
-LOGICAL(LGT) :: isok
-
-tp = SIZE(lambda, 2)
-maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)
-
-a = 3 * tp; b = maxP
-ALLOCATE (phi(a, 0:b), gradientPhi(a, 0:b), d_lambda(a))
-
-DO CONCURRENT(ii=1:tp)
- ! edge 1 -> 2
- d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
- ! edge 2 -> 3
- d_lambda(ii + tp) = lambda(3, ii) - lambda(2, ii)
- ! edge 3 -> 1
- d_lambda(ii + 2 * tp) = lambda(1, ii) - lambda(3, ii)
-END DO
+PURE SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle(order, pe1, &
+ pe2, pe3, lambda, refTriangle, ans, dim1, dim2, dim3, edgeOrient1, &
+ edgeOrient2, edgeOrient3, faceOrient)
+ 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) :: lambda(:, :)
+ !! Barycenteric coordinates
+ !! number of rows = 3
+ !! number of cols = number of points
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! reference triangle, "BIUNIT", "UNIT"
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! dim1=SIZE(lambda, 2)
+ !! dim2=pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
+ !! dim3=3
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! range of data written in ans
+ INTEGER(I4B), INTENT(IN) :: edgeOrient1, edgeOrient2, edgeOrient3
+ !! edge orientation
+ INTEGER(I4B), INTENT(IN) :: faceOrient(2)
+ !! face orientation
+
+ INTEGER(I4B) :: a, b, ii, maxP, indx(3)
+ REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:)
+ LOGICAL(LGT) :: isok
+
+ dim1 = SIZE(lambda, 2)
+ dim2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
+ dim3 = 3
+
+ maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 2, order - 2)
+
+ a = 3 * dim1; b = maxP
+ ALLOCATE (phi(a, 0:b), gradientPhi(a, 0:b), d_lambda(a))
+
+ DO CONCURRENT(ii=1:dim1)
+ ! edge 1 -> 2
+ d_lambda(ii) = lambda(2, ii) - lambda(1, ii)
+ ! edge 2 -> 3
+ d_lambda(ii + dim1) = lambda(3, ii) - lambda(2, ii)
+ ! edge 3 -> 1
+ d_lambda(ii + 2 * dim1) = lambda(1, ii) - lambda(3, ii)
+ END DO
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
+ CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=indx(1), &
+ ncol=indx(2))
-CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
- nrow=a, ncol=b)
+ CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
+ nrow=indx(1), ncol=indx(2))
-! gradient of vertex basis
-ans(1:tp, 1:3, 1:3) = 0.0_DFP
-DO CONCURRENT(ii=1:3)
- ans(1:tp, ii, ii) = 1.0_DFP
-END DO
+ ! gradient of vertex basis
+ ans(1:dim1, 1:3, 1:3) = 0.0_DFP
+ DO CONCURRENT(ii=1:3)
+ ans(1:dim1, ii, ii) = 1.0_DFP
+ END DO
-! gradient of Edge basis function
-b = 3
-isok = ANY([pe1, pe2, pe3] .GE. 2_I4B)
-IF (isok) THEN
- a = b + 1
- b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2
- CALL BarycentricEdgeBasisGradient_Triangle2( &
- pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, &
- phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :))
-END IF
-
-! gradient of Cell basis function
-IF (order .GT. 2_I4B) THEN
- a = b + 1
- b = a - 1 + INT((order - 1) * (order - 2) / 2)
- CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, &
- phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :))
-END IF
-
-DEALLOCATE (phi, gradientPhi, d_lambda)
-END PROCEDURE BarycentricHeirarchicalBasisGradient_Triangle1
+ ! gradient of Edge basis function
+ b = 3
+ isok = ANY([pe1, pe2, pe3] .GE. 2_I4B)
+ IF (isok) THEN
+ a = b + 1
+ b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2
+ CALL BarycentricEdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
+ lambda=lambda, phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :), &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3), edgeOrient1=edgeOrient1, &
+ edgeOrient2=edgeOrient2, edgeOrient3=edgeOrient3)
+ END IF
+
+ ! gradient of Cell basis function
+ isok = order .GT. 2_I4B
+ IF (isok) THEN
+ a = b + 1
+ b = a - 1 + INT((order - 1) * (order - 2) / 2)
+ CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, &
+ phi=phi, gradientPhi=gradientPhi, ans=ans(:, a:b, :), &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3), faceOrient=faceOrient)
+ END IF
+
+ DEALLOCATE (phi, gradientPhi, d_lambda)
+
+END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle
!----------------------------------------------------------------------------
! HeirarchicalBasisGradient_Triangle
@@ -622,21 +1024,37 @@ END SUBROUTINE BarycentricCellBasisGradient_Triangle2
!----------------------------------------------------------------------------
MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1_
+INTEGER(I4B), PARAMETER :: orient = 1, faceOrient(2) = [0, 1]
+
+CALL HeirarchicalBasisGradient_Triangle2_(order=order, pe1=pe1, pe2=pe2, &
+ pe3=pe3, xij=xij, edgeOrient1=orient, edgeOrient2=orient, &
+ edgeOrient3=orient, faceOrient=faceOrient, refTriangle=refTriangle, &
+ ans=ans, tsize1=tsize1, tsize2=tsize2, tsize3=tsize3)
+END PROCEDURE HeirarchicalBasisGradient_Triangle1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Triangle2_
REAL(DFP) :: jac(3, 2)
REAL(DFP), ALLOCATABLE :: lambda(:, :), dPhi(:, :, :)
-INTEGER(I4B) :: ii, jj, kk
+INTEGER(I4B) :: ii, jj, kk, indx(3)
ii = SIZE(xij, 2)
jj = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
ALLOCATE (lambda(3, ii), dPhi(ii, jj, 3))
+
tsize1 = SIZE(xij, 2)
tsize2 = pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2)
tsize3 = 2
CALL BarycentricCoordTriangle_(xin=xij, refTriangle=refTriangle, ans=lambda)
-CALL BarycentricHeirarchicalBasisGradient_Triangle( &
- order=order, pe1=pe1, pe2=pe2, pe3=pe3, lambda=lambda, &
- refTriangle=refTriangle, ans=dPhi)
+
+CALL BarycentricHeirarchicalBasisGradient_Triangle(order=order, pe1=pe1, &
+ pe2=pe2, pe3=pe3, lambda=lambda, refTriangle=refTriangle, ans=dPhi, &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3), edgeOrient1=edgeOrient1, &
+ edgeOrient2=edgeOrient2, edgeOrient3=edgeOrient3, faceOrient=faceOrient)
SELECT CASE (refTriangle(1:1))
CASE ("B", "b")
@@ -657,7 +1075,7 @@ END SUBROUTINE BarycentricCellBasisGradient_Triangle2
DEALLOCATE (lambda, dPhi)
-END PROCEDURE HeirarchicalBasisGradient_Triangle1_
+END PROCEDURE HeirarchicalBasisGradient_Triangle2_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
index 50fd1448c..ff0ef79d0 100644
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
+++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
@@ -21,7 +21,12 @@
USE GE_CompRoutineMethods, ONLY: GetInvMat
USE GE_LUMethods, ONLY: LUSolve, GetLU
+USE F95_BLAS, ONLY: GEMM
+
+USE BaseType, ONLY: polyopt => TypePolynomialOpt, elemopt => TypeElemNameOpt
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -78,42 +83,76 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Triangle1
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Triangle1_(order=order, i=i, xij=xij, ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff_Triangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Triangle1_
REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
INTEGER(I4B) :: info, nrow, ncol
-ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP
+tsize = SIZE(xij, 2)
+
+ipiv = 0_I4B; ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, ans=V, &
- nrow=nrow, ncol=ncol)
+CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elemopt%Triangle, &
+ ans=V, nrow=nrow, ncol=ncol)
CALL GetLU(A=V, IPIV=ipiv, info=info)
-CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Triangle1
+CALL LUSolve(A=V, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Triangle1_
!----------------------------------------------------------------------------
! LagrangeCoeff_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeCoeff_Triangle2
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Triangle2_(order=order, i=i, v=v, &
+ isVandermonde=isVandermonde, ans=ans, tsize=tsize)
+END PROCEDURE LagrangeCoeff_Triangle2
+
+!----------------------------------------------------------------------------
+! 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
+tsize = SIZE(v, 1)
+vtemp = v; ans(1:tsize) = 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
+CALL LUSolve(A=vtemp, B=ans(1:tsize), 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)
+INTEGER(I4B) :: tsize
+CALL LagrangeCoeff_Triangle3_(order=order, i=i, v=v, ipiv=ipiv, ans=ans, &
+ tsize=tsize)
END PROCEDURE LagrangeCoeff_Triangle3
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Triangle3_
+INTEGER(I4B) :: info
+
+tsize = SIZE(v, 1)
+ans(1:tsize) = 0.0_DFP; ans(i) = 1.0_DFP
+CALL LUSolve(A=v, B=ans(1:tsize), IPIV=ipiv, info=info)
+END PROCEDURE LagrangeCoeff_Triangle3_
+
!----------------------------------------------------------------------------
! LagrangeCoeff_Triangle
!----------------------------------------------------------------------------
@@ -122,7 +161,7 @@
INTEGER(I4B) :: basisType0, nrow, ncol
CHARACTER(:), ALLOCATABLE :: ref0
-basisType0 = Input(default=Monomial, option=basisType)
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
ref0 = Input(default="UNIT", option=refTriangle)
CALL LagrangeCoeff_Triangle4_(order=order, xij=xij, basisType=basisType0, &
refTriangle=ref0, ans=ans, nrow=nrow, ncol=ncol)
@@ -137,16 +176,17 @@
SELECT CASE (basisType)
-CASE (Monomial)
- CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, &
+CASE (polyopt%Monomial)
+ CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elemopt%Triangle, &
ans=ans, nrow=nrow, ncol=ncol)
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, &
+ polyopt%Lobatto, polyopt%Ultraspherical)
CALL Dubiner_Triangle_(order=order, xij=xij, refTriangle=refTriangle, &
ans=ans, nrow=nrow, ncol=ncol)
-CASE (Heirarchical)
+CASE (polyopt%Hierarchical)
CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, &
pe3=order, xij=xij, refTriangle=refTriangle, &
@@ -162,12 +202,27 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Triangle1
+INTEGER(I4B) :: tsize
+
+CALL LagrangeEvalAll_Triangle1_(order=order, x=x, xij=xij, ans=ans, &
+ tsize=tsize, refTriangle=refTriangle, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType)
+END PROCEDURE LagrangeEvalAll_Triangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Triangle1_
LOGICAL(LGT) :: firstCall0
INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow
INTEGER(I4B) :: degree(SIZE(xij, 2), 2)
-REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2))
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), &
+ x21(2, 1)
-basisType0 = Input(default=Monomial, option=basisType)
+tsize = SIZE(xij, 2)
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
firstCall0 = Input(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
@@ -176,23 +231,23 @@
CALL LagrangeCoeff_Triangle_(order=order, xij=xij, &
basisType=basisType0, refTriangle=refTriangle, &
ans=coeff, nrow=nrow, ncol=ncol)
- coeff0 = TRANSPOSE(coeff)
- ELSE
- coeff0 = TRANSPOSE(coeff)
END IF
+ ! coeff0 = TRANSPOSE(coeff)
+ coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize)
+
ELSE
CALL LagrangeCoeff_Triangle_(order=order, xij=xij, &
basisType=basisType0, refTriangle=refTriangle, &
ans=coeff0, nrow=nrow, ncol=ncol)
- coeff0 = TRANSPOSE(coeff0)
+ ! coeff0 = TRANSPOSE(coeff0)
END IF
SELECT CASE (basisType0)
-CASE (Monomial)
+CASE (polyopt%Monomial)
CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol)
@@ -202,92 +257,133 @@
xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2)
END DO
-CASE (Heirarchical)
+CASE (polyopt%Hierarchical)
+ x21(1:2, 1) = x(1:2)
CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, &
- pe2=order, pe3=order, xij=RESHAPE(x, [2, 1]), &
+ pe2=order, pe3=order, xij=x21, &
refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow)
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, &
+ polyopt%Ultraspherical)
- CALL Dubiner_Triangle_(order=order, xij=RESHAPE(x, [2, 1]), &
+ x21(1:2, 1) = x(1:2)
+ CALL Dubiner_Triangle_(order=order, xij=x21, &
refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol)
END SELECT
-ans = MATMUL(coeff0, xx(1, :))
-END PROCEDURE LagrangeEvalAll_Triangle1
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :))
+END DO
+
+! ans = MATMUL(coeff0, xx(1, :))
+END PROCEDURE LagrangeEvalAll_Triangle1_
!----------------------------------------------------------------------------
! LagrangeEvalAll_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeEvalAll_Triangle2
+
+INTEGER(I4B) :: nrow, ncol
+
+CALL LagrangeEvalAll_Triangle2_(order=order, x=x, xij=xij, &
+ reftriangle=reftriangle, &
+ coeff=coeff, firstCall=firstCall, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda, nrow=nrow, ncol=ncol, ans=ans)
+END PROCEDURE LagrangeEvalAll_Triangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Triangle2_
LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof, ncol, nrow
+INTEGER(I4B) :: ii, basisType0, tdof, aint, bint
INTEGER(I4B) :: degree(SIZE(xij, 2), 2)
REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2))
-basisType0 = Input(default=Monomial, option=basisType)
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
firstCall0 = Input(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
IF (firstCall0) THEN
CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, &
- refTriangle=refTriangle, ans=coeff, nrow=nrow, ncol=ncol)
- coeff0 = coeff
+ refTriangle=refTriangle, ans=coeff, nrow=aint, ncol=bint)
- ELSE
+ END IF
- coeff0 = coeff
+ coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol)
- END IF
ELSE
CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, &
- refTriangle=refTriangle, ans=coeff0, nrow=nrow, ncol=ncol)
+ refTriangle=refTriangle, ans=coeff0, nrow=aint, ncol=bint)
END IF
SELECT CASE (basisType0)
-CASE (Monomial)
+CASE (polyopt%Monomial)
- CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol)
+ CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=aint, ncol=bint)
tdof = SIZE(xij, 2)
DO ii = 1, tdof
xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2)
END DO
-CASE (Heirarchical)
+CASE (polyopt%Hierarchical)
CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, &
- pe3=order, xij=x, refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow)
+ pe3=order, xij=x, refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint)
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, &
+ polyopt%Ultraspherical)
CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, &
- ans=xx, nrow=nrow, ncol=ncol)
+ ans=xx, nrow=aint, ncol=bint)
END SELECT
-ans = MATMUL(xx, coeff0)
-END PROCEDURE LagrangeEvalAll_Triangle2
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff0)
+END PROCEDURE LagrangeEvalAll_Triangle2_
!----------------------------------------------------------------------------
! LagrangeGradientEvalAll_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1
+INTEGER(I4B) :: dim1, dim2, dim3
+
+CALL LagrangeGradientEvalAll_Triangle1_(order=order, x=x, xij=xij, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3, refTriangle=refTriangle, coeff=coeff, &
+ firstCall=firstCall, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda)
+
+END PROCEDURE LagrangeGradientEvalAll_Triangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Triangle1_
LOGICAL(LGT) :: firstCall0
INTEGER(I4B) :: ii, basisType0, tdof, ai, bi, s(3)
INTEGER(I4B) :: degree(SIZE(xij, 2), 2)
REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), &
- & xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br
+ xx(SIZE(x, 2), SIZE(xij, 2), 2), ar, br
-basisType0 = Input(default=Monomial, option=basisType)
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = 2
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
firstCall0 = Input(default=.TRUE., option=firstCall)
IF (PRESENT(coeff)) THEN
@@ -296,7 +392,8 @@
refTriangle=refTriangle, ans=coeff, nrow=s(1), ncol=s(2))
END IF
- coeff0 = coeff
+ coeff0(1:dim2, 1:dim2) = coeff(1:dim2, 1:dim2)
+
ELSE
CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, &
refTriangle=refTriangle, ans=coeff0, nrow=s(1), ncol=s(2))
@@ -304,7 +401,7 @@
SELECT CASE (basisType0)
-CASE (Monomial)
+CASE (polyopt%Monomial)
CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=s(1), ncol=s(2))
@@ -319,13 +416,14 @@
xx(:, ii, 2) = x(1, :)**degree(ii, 1) * (br * x(2, :)**bi)
END DO
-CASE (Heirarchical)
+CASE (polyopt%Hierarchical)
CALL HeirarchicalBasisGradient_Triangle_(order=order, pe1=order, pe2=order, &
pe3=order, xij=x, refTriangle=refTriangle, ans=xx, tsize1=s(1), &
tsize2=s(2), tsize3=s(3))
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, &
+ polyopt%Ultraspherical)
CALL OrthogonalBasisGradient_Triangle_(order=order, xij=x, &
refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3))
@@ -334,10 +432,10 @@
DO ii = 1, 2
! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
- ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0)
+ ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0)
END DO
-END PROCEDURE LagrangeGradientEvalAll_Triangle1
+END PROCEDURE LagrangeGradientEvalAll_Triangle1_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90
index 9e50e8c6a..1589a40e1 100644
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90
@@ -15,7 +15,27 @@
! along with this program. If not, see
SUBMODULE(TriangleInterpolationUtility) Methods
-USE BaseMethod
+USE BaseType, ONLY: ipopt => TypeInterpolationOpt
+
+USE StringUtility, ONLY: UpperCase
+
+USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line, &
+ EquidistanceInPoint_Line_, &
+ LagrangeInDOF_Line, &
+ InterpolationPoint_Line_
+
+USE MappingUtility, ONLY: FromUnitTriangle2Triangle_
+
+USE ErrorHandling, ONLY: Errormsg
+
+USE RecursiveNodesUtility, ONLY: RecursiveNode2D_
+
+USE IntegerUtility, ONLY: Size
+
+USE Display_Method, ONLY: ToString
+
+USE GlobalData, ONLY: stderr
+
IMPLICIT NONE
CONTAINS
@@ -40,41 +60,46 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE RefElemDomain_Triangle
-SELECT CASE (UpperCase(baseContinuity))
+CHARACTER(2) :: bc
+CHARACTER(3) :: bi
+
+bc = UpperCase(baseContinuity(1:2))
+bi = UpperCase(baseInterpol(1:3))
+
+SELECT CASE (bc)
+
CASE ("H1")
- SELECT CASE (UpperCase(baseInterpol))
- CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION")
- ans = "UNIT"
- CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION")
- ans = "UNIT"
- CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION")
+
+ SELECT CASE (bi)
+
+ !! Lagrange
+ CASE ("LAG", "SER", "HER")
ans = "UNIT"
- CASE ( &
- & "HIERARCHICALPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHICALPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION")
+
+ CASE ("HIE", "HEI")
ans = "BIUNIT"
- CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION")
+
+ CASE ("ORT")
ans = "BIUNIT"
+
CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for given baseInterpol="//TRIM(baseInterpol), &
- & file=__FILE__, &
- & line=__LINE__,&
- & routine="RefElemDomain_Triangle()", &
- & unitno=stderr)
+
+ CALL Errormsg( &
+ msg="No case found for given baseInterpol="//TRIM(baseInterpol), &
+ routine="RefElemDomain_Triangle()", file=__FILE__, line=__LINE__, &
+ unitno=stderr)
+
END SELECT
+
CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for given baseContinuity="//TRIM(baseContinuity), &
- & file=__FILE__, &
- & line=__LINE__,&
- & routine="RefElemDomain_Triangle()", &
- & unitno=stderr)
+
+ CALL Errormsg( &
+ msg="No case found for given baseContinuity="//TRIM(baseContinuity), &
+ file=__FILE__, line=__LINE__, routine="RefElemDomain_Triangle()", &
+ unitno=stderr)
+
END SELECT
+
END PROCEDURE RefElemDomain_Triangle
!----------------------------------------------------------------------------
@@ -82,30 +107,21 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FacetConnectivity_Triangle
-TYPE(String) :: baseInterpol0
-TYPE(String) :: baseContinuity0
-
-baseInterpol0 = UpperCase(baseInterpol)
-baseContinuity0 = UpperCase(baseContinuity)
-
-SELECT CASE (baseInterpol0%chars())
-CASE ( &
- & "HIERARCHYPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHYPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION", &
- & "ORTHOGONALPOLYNOMIAL", &
- & "ORTHOGONAL", &
- & "ORTHOGONALINTERPOLATION")
+CHARACTER(3) :: bi
+
+bi = UpperCase(baseInterpol(1:3))
+
+SELECT CASE (bi)
+CASE ("HIE", "HEI", "ORT")
ans(:, 1) = [1, 2]
ans(:, 2) = [1, 3]
ans(:, 3) = [2, 3]
+
CASE DEFAULT
ans(:, 1) = [1, 2]
ans(:, 2) = [2, 3]
ans(:, 3) = [3, 1]
+
END SELECT
END PROCEDURE FacetConnectivity_Triangle
@@ -114,201 +130,261 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistancePoint_Triangle
-INTEGER(I4B) :: nsd, n, ne, i1, i2
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2_I4B
+END IF
+
+ncol = LagrangeDOF_Triangle(order=order)
+ALLOCATE (ans(nrow, ncol))
+
+CALL EquidistancePoint_Triangle_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+END PROCEDURE EquidistancePoint_Triangle
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Triangle_
+INTEGER(I4B) :: i1, i2, aint, bint
REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu
x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- x(1:nsd, 1:3) = xij(1:nsd, 1:3)
+ nrow = SIZE(xij, 1)
+ x(1:nrow, 1:3) = xij(1:nrow, 1:3)
ELSE
- nsd = 2_I4B
- x(1:nsd, 1) = [0.0, 0.0]
- x(1:nsd, 2) = [1.0, 0.0]
- x(1:nsd, 3) = [0.0, 1.0]
+ nrow = 2_I4B
+ x(1:nrow, 1) = [0.0, 0.0]
+ x(1:nrow, 2) = [1.0, 0.0]
+ x(1:nrow, 3) = [0.0, 1.0]
END IF
-n = LagrangeDOF_Triangle(order=order)
-ALLOCATE (ans(nsd, n))
-ans = 0.0_DFP
+ncol = LagrangeDOF_Triangle(order=order)
+! ALLOCATE (ans(nrow, n))
+! ans = 0.0_DFP
!! points on vertex
-ans(1:nsd, 1:3) = x(1:nsd, 1:3)
+ans(1:nrow, 1:3) = x(1:nrow, 1:3)
!! points on edge
-ne = LagrangeInDOF_Line(order=order)
+! ne = LagrangeInDOF_Line(order=order)
i2 = 3
IF (order .GT. 1_I4B) THEN
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [1, 2]))
- !!
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [2, 3]))
- !!
- i1 = i2 + 1; i2 = i1 + ne - 1
- ans(1:nsd, i1:i2) = EquidistanceInPoint_Line( &
- & order=order, &
- & xij=x(1:nsd, [3, 1]))
- !!
+ i1 = i2 + 1
+ ! i1 = i2 + 1; i2 = i1 + ne - 1
+ ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( &
+ ! order=order, &
+ ! xij=x(1:nrow, [1, 2]))
+ CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [1, 2]), &
+ ans=ans(:, i1:), nrow=aint, ncol=bint)
+
+ i1 = i1 + bint
+ ! i1 = i2 + 1; i2 = i1 + ne - 1
+ ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( &
+ ! order=order, &
+ ! xij=x(1:nrow, [2, 3]))
+ CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [2, 3]), &
+ ans=ans(:, i1:), nrow=aint, ncol=bint)
+
+ i1 = i1 + bint
+ ! i1 = i2 + 1; i2 = i1 + ne - 1
+ ! ans(1:nrow, i1:i2) = EquidistanceInPoint_Line( &
+ ! order=order, &
+ ! xij=x(1:nrow, [3, 1]))
+ CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [3, 1]), &
+ ans=ans(:, i1:), nrow=aint, ncol=bint)
+ i2 = i1 + bint - 1
+
END IF
+IF (order .LE. 2_I4B) RETURN
+
!! points on face
-IF (order .GT. 2_I4B) THEN
- !!
- IF (order .EQ. 3_I4B) THEN
- i1 = i2 + 1
- ans(1:nsd, i1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP
- ELSE
- !!
- e1 = x(:, 2) - x(:, 1)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 3) - x(:, 1)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd)
- !!
- e1 = x(:, 3) - x(:, 2)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 1) - x(:, 2)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd)
- !!
- e1 = x(:, 1) - x(:, 3)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 2) - x(:, 3)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd)
- !!
- i1 = i2 + 1
- ans(1:nsd, i1:) = EquidistancePoint_Triangle( &
- & order=order - 3, &
- & xij=xin(1:nsd, 1:3))
- !!
- END IF
+IF (order .EQ. 3_I4B) THEN
+ i1 = i2 + 1
+ ans(1:nrow, i1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP
+ RETURN
END IF
-END PROCEDURE EquidistancePoint_Triangle
+e1 = x(:, 2) - x(:, 1)
+avar = NORM2(e1)
+e1 = e1 / avar
+lam = avar / order
+e2 = x(:, 3) - x(:, 1)
+avar = NORM2(e2)
+e2 = e2 / avar
+mu = avar / order
+xin(1:nrow, 1) = x(1:nrow, 1) + lam * e1(1:nrow) + mu * e2(1:nrow)
+
+e1 = x(:, 3) - x(:, 2)
+avar = NORM2(e1)
+e1 = e1 / avar
+lam = avar / order
+e2 = x(:, 1) - x(:, 2)
+avar = NORM2(e2)
+e2 = e2 / avar
+mu = avar / order
+xin(1:nrow, 2) = x(1:nrow, 2) + lam * e1(1:nrow) + mu * e2(1:nrow)
+
+e1 = x(:, 1) - x(:, 3)
+avar = NORM2(e1)
+e1 = e1 / avar
+lam = avar / order
+e2 = x(:, 2) - x(:, 3)
+avar = NORM2(e2)
+e2 = e2 / avar
+mu = avar / order
+xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow)
+
+i1 = i2 + 1
+! ans(1:nrow, i1:) = EquidistancePoint_Triangle(order=order - 3, &
+! xij=xin(1:nrow, 1:3))
+CALL EquidistancePoint_Triangle_(order=order - 3, xij=xin(1:nrow, 1:3), &
+ ans=ans(1:nrow, i1:), nrow=aint, ncol=bint)
+
+END PROCEDURE EquidistancePoint_Triangle_
!----------------------------------------------------------------------------
! EquidistanceInPoint_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE EquidistanceInPoint_Triangle
-INTEGER(I4B) :: nsd, n
-REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu
+INTEGER(I4B) :: nrow, ncol
IF (order .LT. 3_I4B) THEN
ALLOCATE (ans(0, 0))
RETURN
END IF
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2_I4B
+END IF
+
+ncol = LagrangeInDOF_Triangle(order=order)
+
+CALL EquidistanceInPoint_Triangle_(order=order, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+END PROCEDURE EquidistanceInPoint_Triangle
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Triangle_
+REAL(DFP) :: x(3, 3), xin(3, 3), e1(3), e2(3), lam, avar, mu
+INTEGER(I4B) :: aint, bint
+
+nrow = 0; ncol = 0
+IF (order .LT. 3_I4B) RETURN
+
x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- x(1:nsd, 1:3) = xij(1:nsd, 1:3)
+ nrow = SIZE(xij, 1)
+ x(1:nrow, 1:3) = xij(1:nrow, 1:3)
ELSE
- nsd = 2_I4B
- x(1:nsd, 1) = [0.0, 0.0]
- x(1:nsd, 2) = [1.0, 0.0]
- x(1:nsd, 3) = [0.0, 1.0]
+ nrow = 2_I4B
+ x(1:nrow, 1) = [0.0, 0.0]
+ x(1:nrow, 2) = [1.0, 0.0]
+ x(1:nrow, 3) = [0.0, 1.0]
END IF
-n = LagrangeInDOF_Triangle(order=order)
-ALLOCATE (ans(nsd, n))
-ans = 0.0_DFP
+ncol = LagrangeInDOF_Triangle(order=order)
+! ALLOCATE (ans(nrow, n))
+! ans = 0.0_DFP
!! points on face
IF (order .EQ. 3_I4B) THEN
- ans(1:nsd, 1) = (x(1:nsd, 1) + x(1:nsd, 2) + x(1:nsd, 3)) / 3.0_DFP
-ELSE
- !!
- e1 = x(:, 2) - x(:, 1)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 3) - x(:, 1)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 1) = x(1:nsd, 1) + lam * e1(1:nsd) + mu * e2(1:nsd)
- !!
- e1 = x(:, 3) - x(:, 2)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 1) - x(:, 2)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 2) = x(1:nsd, 2) + lam * e1(1:nsd) + mu * e2(1:nsd)
- !!
- e1 = x(:, 1) - x(:, 3)
- avar = NORM2(e1)
- e1 = e1 / avar
- lam = avar / order
- e2 = x(:, 2) - x(:, 3)
- avar = NORM2(e2)
- e2 = e2 / avar
- mu = avar / order
- xin(1:nsd, 3) = x(1:nsd, 3) + lam * e1(1:nsd) + mu * e2(1:nsd)
- !!
- ans(1:nsd, 1:) = EquidistancePoint_Triangle( &
- & order=order - 3, &
- & xij=xin(1:nsd, 1:3))
- !!
+ ans(1:nrow, 1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP
+ RETURN
END IF
-END PROCEDURE EquidistanceInPoint_Triangle
+e1 = x(:, 2) - x(:, 1)
+avar = NORM2(e1)
+e1 = e1 / avar
+lam = avar / order
+e2 = x(:, 3) - x(:, 1)
+avar = NORM2(e2)
+e2 = e2 / avar
+mu = avar / order
+xin(1:nrow, 1) = x(1:nrow, 1) + lam * e1(1:nrow) + mu * e2(1:nrow)
+
+e1 = x(:, 3) - x(:, 2)
+avar = NORM2(e1)
+e1 = e1 / avar
+lam = avar / order
+e2 = x(:, 1) - x(:, 2)
+avar = NORM2(e2)
+e2 = e2 / avar
+mu = avar / order
+xin(1:nrow, 2) = x(1:nrow, 2) + lam * e1(1:nrow) + mu * e2(1:nrow)
+
+e1 = x(:, 1) - x(:, 3)
+avar = NORM2(e1)
+e1 = e1 / avar
+lam = avar / order
+e2 = x(:, 2) - x(:, 3)
+avar = NORM2(e2)
+e2 = e2 / avar
+mu = avar / order
+xin(1:nrow, 3) = x(1:nrow, 3) + lam * e1(1:nrow) + mu * e2(1:nrow)
+
+CALL EquidistancePoint_Triangle_(order=order - 3, xij=xin(1:nrow, 1:3), &
+ ans=ans, nrow=aint, ncol=bint)
+
+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(*), PARAMETER :: myName = "BlythPozrikidis_Triangle"
-
-v = InterpolationPoint_Line( &
- & order=order, &
- & ipType=ipType, &
- & xij=[0.0_DFP, 1.0_DFP], &
- & layout="INCREASING", &
- & lambda=lambda, &
- & beta=beta, &
- & alpha=alpha)
-
-N = LagrangeDOF_Triangle(order=order)
+INTEGER(I4B) :: nrow, ncol
+ncol = LagrangeDOF_Triangle(order=order)
+nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1)
+ALLOCATE (ans(nrow, ncol))
+CALL BlythPozrikidis_Triangle_(order=order, ipType=ipType, ans=ans,nrow=nrow,&
+ ncol=ncol, layout=layout, xij=xij, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE BlythPozrikidis_Triangle
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BlythPozrikidis_Triangle_
+INTEGER(I4B), PARAMETER :: max_order = 30
+CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle()"
+REAL(DFP), PARAMETER :: x(2) = [0.0_DFP, 1.0_DFP]
+
+REAL(DFP) :: v(max_order + 1), xi(max_order + 1, max_order + 1), &
+ eta(max_order + 1, max_order + 1), temp(2, 512)
-CALL Reallocate(ans, nsd, N)
-CALL Reallocate(temp, 2, N)
+INTEGER(I4B) :: ii, jj, kk, tsize
-xi = 0.0_DFP
-eta = 0.0_DFP
+LOGICAL(LGT) :: isx
+
+CALL InterpolationPoint_Line_(order=order, ipType=ipType, xij=x, &
+ layout="INCREASING", lambda=lambda, &
+ beta=beta, alpha=alpha, ans=v, tsize=tsize)
+
+ncol = LagrangeDOF_Triangle(order=order)
+nrow = 2
+
+isx = .FALSE.; IF (PRESENT(xij)) isx = .TRUE.
+IF (isx) nrow = SIZE(xij, 1)
+
+xi(1:order + 1, 1:order + 1) = 0.0_DFP
+eta(1:order + 1, 1:order + 1) = 0.0_DFP
DO ii = 1, order + 1
DO jj = 1, order + 2 - ii
@@ -318,91 +394,101 @@
END DO
END DO
-IF (layout .EQ. "VEFC") THEN
+SELECT CASE (layout)
- CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N)
+CASE ("VEFC")
- IF (PRESENT(xij)) THEN
- ans = FromUnitTriangle2Triangle(xin=temp, &
- & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3))
- ELSE
- ans = temp
+ CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol)
+
+ IF (isx) THEN
+ CALL FromUnitTriangle2Triangle_(xin=temp(1:2, 1:ncol), x1=xij(:, 1), &
+ x2=xij(:, 2), x3=xij(:, 3), ans=ans, nrow=nrow, ncol=ncol)
+ RETURN
END IF
-ELSE
- CALL ErrorMsg( &
- & msg="Only layout=VEFC is allowed, given layout is " &
- & //TRIM(layout), &
- & file=__FILE__, &
- & routine=myname, &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END IF
+ ans(1:2, 1:ncol) = temp(1:2, 1:ncol)
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
+CASE DEFAULT
-END PROCEDURE BlythPozrikidis_Triangle
+ CALL ErrorMsg(msg="layout=VEFC is allowed, found layout is "//TRIM(layout), &
+ file=__FILE__, routine=myname, line=__LINE__, unitno=stderr)
+
+END SELECT
+
+END PROCEDURE BlythPozrikidis_Triangle_
!----------------------------------------------------------------------------
! Isaac_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(*), PARAMETER :: myName = "Isaac_Triangle"
+INTEGER(I4B) :: nrow, ncol
-rPoints = RecursiveNode2D(order=order, ipType=ipType, domain="UNIT", &
- & alpha=alpha, beta=beta, lambda=lambda)
+ncol = SIZE(n=order, d=2)
+nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1)
-N = SIZE(rPoints, 2)
+ALLOCATE (ans(nrow, ncol))
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
+CALL Isaac_Triangle_(order=order, ipType=ipType, ans=ans, nrow=nrow, &
+ ncol=ncol, layout=layout, xij=xij, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+END PROCEDURE Isaac_Triangle
+
+!----------------------------------------------------------------------------
+! Isaac_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Isaac_Triangle_
+CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle()"
+INTEGER(I4B), PARAMETER :: max_order = 30
+REAL(DFP) :: xi(max_order + 1, max_order + 1), &
+ eta(max_order + 1, max_order + 1), &
+ temp(2, 512)
-CALL Reallocate(ans, nsd, N)
+! REAL(DFP), ALLOCATABLE :: temp(:, :), rPoints(:, :)
+INTEGER(I4B) :: cnt, ii, jj
+INTEGER(I4B) :: nn
+
+nn = 1 + order
+
+CALL RecursiveNode2D_(order=order, ipType=ipType, domain="UNIT", &
+ alpha=alpha, beta=beta, lambda=lambda, ans=temp, &
+ nrow=nrow, ncol=ncol)
+
+IF (PRESENT(xij)) nrow = SIZE(xij, 1)
!! convert from rPoints to xi and eta
cnt = 0
-xi = 0.0_DFP
-eta = 0.0_DFP
+xi(1:nn, 1:nn) = 0.0_DFP
+eta(1:nn, 1:nn) = 0.0_DFP
-DO ii = 1, order + 1
- DO jj = 1, order + 2 - ii
+DO ii = 1, nn
+ DO jj = 1, nn + 1 - ii
cnt = cnt + 1
- xi(ii, jj) = rPoints(1, cnt)
- eta(ii, jj) = rPoints(2, cnt)
+ xi(ii, jj) = temp(1, cnt)
+ eta(ii, jj) = temp(2, cnt)
END DO
END DO
IF (layout .EQ. "VEFC") THEN
- CALL Reallocate(temp, 2, N)
- CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N)
+ ! CALL Reallocate(temp, 2, N)
+ CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol)
+
IF (PRESENT(xij)) THEN
- ans = FromUnitTriangle2Triangle(xin=temp, &
- & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3))
- ELSE
- ans = temp
+ CALL FromUnitTriangle2Triangle_(xin=temp(:, 1:ncol), ans=ans, &
+ nrow=nrow, ncol=ncol, x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3))
+ RETURN
END IF
-ELSE
- CALL ErrorMsg( &
- & msg="Only layout=VEFC is allowed, given layout is " &
- & //TRIM(layout), &
- & file=__FILE__, &
- & routine=myname, &
- & line=__LINE__, &
- & unitno=stderr)
+
+ ans(1:nrow, 1:ncol) = temp(1:nrow, 1:ncol)
RETURN
END IF
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
-IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints)
-END PROCEDURE Isaac_Triangle
+CALL ErrorMsg(file=__FILE__, routine=myname, line=__LINE__, unitno=stderr, &
+ msg="Only layout=VEFC is allowed, found layout is "//layout)
+
+END PROCEDURE Isaac_Triangle_
!----------------------------------------------------------------------------
!
@@ -465,15 +551,13 @@
END IF
IF (cnt .NE. N) THEN
- CALL ErrorMsg( &
- & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" &
- & //tostring(N), &
- & file=__FILE__, &
- & routine="IJ2VEFC_Triangle()", &
- & line=__LINE__, &
- & unitno=stderr)
+ CALL ErrorMsg(file=__FILE__, routine="IJ2VEFC_Triangle()", &
+ line=__LINE__, unitno=stderr, &
+ msg="cnt="//ToString(cnt)//" not equal to total DOF, N=" &
+ //ToString(N))
RETURN
END IF
+
END PROCEDURE IJ2VEFC_Triangle
!----------------------------------------------------------------------------
@@ -481,67 +565,78 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE InterpolationPoint_Triangle
-CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle"
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2
+END IF
SELECT CASE (ipType)
-CASE (Equidistance)
- 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)
- RETURN
-CASE (BlythPozLegendre)
- ans = BlythPozrikidis_Triangle( &
- & order=order, &
- & ipType=GaussLegendreLobatto, &
- & layout="VEFC", &
- & xij=xij, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-CASE (BlythPozChebyshev)
- ans = BlythPozrikidis_Triangle( &
- & order=order, &
- & ipType=GaussChebyshevLobatto, &
- & layout="VEFC", &
- & xij=xij, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-CASE (IsaacLegendre, GaussLegendreLobatto)
- ans = Isaac_Triangle( &
- & order=order, &
- & ipType=GaussLegendreLobatto, &
- & layout="VEFC", &
- & xij=xij, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-CASE (IsaacChebyshev, GaussChebyshevLobatto)
- ans = Isaac_Triangle( &
- & order=order, &
- & ipType=GaussChebyshevLobatto, &
- & layout="VEFC", &
- & xij=xij, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-CASE DEFAULT
- ans = Isaac_Triangle( &
- & order=order, &
- & ipType=ipType, &
- & layout="VEFC", &
- & xij=xij, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
+CASE (ipopt%Equidistance, ipopt%BlythPozChebyshev, ipopt%BlythPozLegendre)
+ ncol = LagrangeDOF_Triangle(order=order)
+
+CASE (ipopt%IsaacLegendre, ipopt%IsaacChebyshev, &
+ ipopt%GaussLegendreLobatto, ipopt%GaussChebyshevLobatto)
+ ncol = SIZE(n=order, d=2)
+
END SELECT
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL InterpolationPoint_Triangle_(order=order, ipType=ipType, ans=ans, &
+ nrow=nrow, ncol=ncol, xij=xij, alpha=alpha, &
+ beta=beta, lambda=lambda, layout=layout)
+
END PROCEDURE InterpolationPoint_Triangle
+!----------------------------------------------------------------------------
+! InterpolationPoint_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Triangle_
+CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle_()"
+
+SELECT CASE (ipType)
+CASE (ipopt%Equidistance)
+ CALL EquidistancePoint_Triangle_(xij=xij, order=order, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+CASE (ipopt%BlythPozLegendre)
+ CALL BlythPozrikidis_Triangle_(order=order, ans=ans, nrow=nrow, ncol=ncol, &
+ ipType=ipopt%GaussLegendreLobatto, layout="VEFC", xij=xij, &
+ alpha=alpha, beta=beta, lambda=lambda)
+
+CASE (ipopt%BlythPozChebyshev)
+ CALL BlythPozrikidis_Triangle_(order=order, &
+ ipType=ipopt%GaussChebyshevLobatto, &
+ layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (ipopt%IsaacLegendre, ipopt%GaussLegendreLobatto)
+ CALL Isaac_Triangle_(order=order, &
+ ipType=ipopt%GaussLegendreLobatto, &
+ layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (ipopt%IsaacChebyshev, ipopt%GaussChebyshevLobatto)
+ CALL Isaac_Triangle_(order=order, ipType=ipopt%GaussChebyshevLobatto, &
+ layout="VEFC", xij=xij, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (ipopt%Feket, ipopt%Hesthaven, ipopt%ChenBabuska)
+ CALL ErrorMsg(msg="Feket, Hesthaven, ChenBabuska nodes not available", &
+ file=__FILE__, routine=myname, line=__LINE__, unitno=stderr)
+
+CASE DEFAULT
+ CALL Isaac_Triangle_(order=order, ipType=ipType, layout="VEFC", &
+ xij=xij, alpha=alpha, beta=beta, lambda=lambda, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END SELECT
+
+END PROCEDURE InterpolationPoint_Triangle_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90
index 26a49cb99..0badc8787 100644
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90
+++ b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90
@@ -22,195 +22,280 @@
IMPLICIT NONE
CONTAINS
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadratureNumber_Triangle
+ans = QuadratureNumberTriangleSolin(order=order)
+
+IF (ans .LE. 0) THEN
+ ans = 1_I4B + INT(order / 2, kind=I4B)
+ ans = ans * (ans + 1)
+END IF
+END PROCEDURE QuadratureNumber_Triangle
+
!----------------------------------------------------------------------------
! TensorQuadraturePoint_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorQuadraturePoint_Triangle1
-INTEGER(I4B) :: np(1), nq(1), n
-n = 1_I4B + INT(order / 2, kind=I4B)
-np(1) = n + 1
-nq(1) = n
-ans = TensorQuadraturePoint_Triangle2( &
- & nipsx=np, &
- & nipsy=nq, &
- & quadType=quadType, &
- & refTriangle=refTriangle, &
- & xij=xij)
+INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol
+
+nrow = 1_I4B + INT(order / 2, kind=I4B)
+nipsx(1) = nrow + 1
+nipsy(1) = nrow
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), 2_I4B)
+ELSE
+ nrow = 2_I4B
+END IF
+
+nrow = nrow + 1_I4B
+ncol = nipsx(1) * nipsy(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, &
+ quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE TensorQuadraturePoint_Triangle1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorQuadraturePoint_Triangle1_
+INTEGER(I4B) :: nipsx(1), nipsy(1), n
+
+n = 1_I4B + INT(order / 2, kind=I4B)
+nipsx(1) = n + 1
+nipsy(1) = n
+
+CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, &
+ quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE TensorQuadraturePoint_Triangle1_
+
!----------------------------------------------------------------------------
! TensorQuadraturePoint_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE TensorQuadraturePoint_Triangle2
-INTEGER(I4B) :: np(1), nq(1), nsd
-REAL(DFP), ALLOCATABLE :: temp_q(:, :), temp_t(:, :)
-TYPE(String) :: astr
-
-astr = TRIM(UpperCase(refTriangle))
-np(1) = nipsx(1)
-nq(1) = nipsy(1)
-
-temp_q = QuadraturePoint_Quadrangle(&
- & nipsx=np, &
- & nipsy=nq, &
- & quadType1=GaussLegendreLobatto, &
- & quadType2=GaussJacobiRadauLeft, &
- & refQuadrangle="BIUNIT", &
- & alpha2=1.0_DFP, &
- & beta2=0.0_DFP)
-
-CALL Reallocate(temp_t, SIZE(temp_q, 1, kind=I4B), SIZE(temp_q, 2, kind=I4B))
-temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :))
-temp_t(3, :) = temp_q(3, :) / 8.0_DFP
+INTEGER(I4B) :: nrow, ncol
IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
+ nrow = MAX(SIZE(xij, 1), 2_I4B)
ELSE
- nsd = 2_I4B
+ nrow = 2_I4B
END IF
-CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_q, 2, kind=I4B))
+nrow = nrow + 1_I4B
+ncol = nipsx(1) * nipsy(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL TensorQuadraturePoint_Triangle2_(nipsx=nipsx, nipsy=nipsy, &
+ quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE TensorQuadraturePoint_Triangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorQuadraturePoint_Triangle2_
+INTEGER(I4B) :: nsd, ii, jj
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+REAL(DFP) :: areal
+REAL(DFP), PARAMETER :: oneby8 = 1.0_DFP / 8.0_DFP
+
+CHARACTER(1) :: astr
IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromUnitTriangle2Triangle( &
- & xin=temp_t(1:2, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3))
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( &
- & from="UNIT", &
- & to="TRIANGLE", &
- & xij=xij)
+ nsd = MAX(SIZE(xij, 1), 2_I4B)
ELSE
- IF (astr%chars() .EQ. "BIUNIT") THEN
- ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :))
+ nsd = 2_I4B
+END IF
+
+nrow = nsd + 1_I4B
+ncol = nipsx(1) * nipsy(1)
+
+! ALLOCATE (temp(nrow, ncol))
+
+CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, &
+ quadType1=GaussLegendreLobatto, quadType2=GaussJacobiRadauLeft, &
+ refQuadrangle="BIUNIT", alpha2=1.0_DFP, beta2=0.0_DFP, ans=ans, &
+ nrow=ii, ncol=jj)
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( &
- & from="UNIT", &
- & to="BIUNIT")
+! temp_t(1:2, :) = FromBiUnitSqr2UnitTriangle(xin=temp_q(1:2, :))
+CALL FromSquare2Triangle_(xin=ans(1:2, :), ans=ans, nrow=ii, ncol=jj, &
+ from="BIUNIT", to="UNIT")
- ELSE
- ans = temp_t
- END IF
+DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * oneby8
+END DO
+
+IF (PRESENT(xij)) THEN
+ CALL FromUnitTriangle2Triangle_(xin=ans(1:2, :), x1=xij(:, 1), &
+ x2=xij(:, 2), x3=xij(:, 3), ans=ans, nrow=ii, ncol=jj)
+
+ areal = JacobianTriangle(from="UNIT", to="TRIANGLE", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
END IF
-IF (ALLOCATED(temp_q)) DEALLOCATE (temp_q)
-IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
+astr = UpperCase(refTriangle(1:1))
-END PROCEDURE TensorQuadraturePoint_Triangle2
+IF (astr .EQ. "B") THEN
+ CALL FromTriangle2Triangle_(xin=ans(1:2, :), ans=ans, nrow=ii, &
+ ncol=jj, from="UNIT", to="BIUNIT")
+
+ areal = JacobianTriangle(from="UNIT", to="BIUNIT")
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
+ RETURN
+
+END IF
+
+END PROCEDURE TensorQuadraturePoint_Triangle2_
!----------------------------------------------------------------------------
! QuadraturePoint_Triangle
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePoint_Triangle1
-INTEGER(I4B) :: nips(1), nsd, ii, jj
-REAL(DFP), ALLOCATABLE :: temp_t(:, :)
+INTEGER(I4B) :: nrow, ncol
LOGICAL(LGT) :: abool
+ncol = QuadratureNumberTriangleSolin(order=order)
+
+nrow = 2_I4B
+abool = PRESENT(xij)
+IF (abool) nrow = SIZE(xij, 1)
+nrow = nrow + 1
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL QuadraturePoint_Triangle1_(order=order, quadType=quadType, &
+ refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE QuadraturePoint_Triangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Triangle1_
+INTEGER(I4B) :: nips(1)
+
nips(1) = QuadratureNumberTriangleSolin(order=order)
IF (nips(1) .LE. 0) THEN
- ans = TensorQuadraturepoint_Triangle(order=order, quadtype=quadtype, &
- reftriangle=reftriangle, xij=xij)
+ CALL TensorQuadraturepoint_Triangle_(order=order, quadtype=quadtype, &
+ reftriangle=reftriangle, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
RETURN
END IF
-ALLOCATE (temp_t(3, nips(1)))
-CALL QuadraturePointTriangleSolin_(nips=nips, ans=temp_t, nrow=ii, &
- ncol=jj)
+CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, &
+ refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
-nsd = 2_I4B
+END PROCEDURE QuadraturePoint_Triangle1_
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Triangle2
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Triangle2
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: abool
+
+nrow = 2_I4B
abool = PRESENT(xij)
-IF (abool) nsd = SIZE(xij, 1)
+IF (abool) nrow = SIZE(xij, 1)
-ii = nsd + 1
-ALLOCATE (ans(ii, jj))
+nrow = nrow + 1
+ncol = nips(1)
-IF (abool) THEN
+ALLOCATE (ans(nrow, ncol))
- CALL FromTriangle2Triangle_(xin=temp_t(1:2, :), x1=xij(1:nsd, 1), &
- x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans(1:nsd, :), &
- from="U", to="T")
+CALL QuadraturePoint_Triangle2_(nips=nips, quadType=quadType, &
+ refTriangle=refTriangle, xij=xij, ans=ans, nrow=nrow, ncol=ncol)
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", &
- to="TRIANGLE", xij=xij)
+END PROCEDURE QuadraturePoint_Triangle2
- RETURN
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Triangle2_
+INTEGER(I4B) :: nsd, ii, jj
+LOGICAL(LGT) :: abool
+REAL(DFP) :: areal
+CHARACTER(1) :: astr
+nrow = 0
+ncol = 0
+
+ii = QuadratureNumberTriangleSolin(order=20)
+abool = nips(1) .GT. ii
+IF (abool) THEN
+ CALL Errormsg(msg="This routine should be called for economical &
+ & quadrature points only, otherwise call QuadraturePoint_Triangle1()", &
+ routine="QuadraturePoint_Triangle2()", &
+ file=__FILE__, line=__LINE__, unitNo=stdout)
+ RETURN
END IF
-abool = reftriangle(1:1) == "B" .OR. reftriangle(1:1) == "b"
+nsd = 2_I4B
+abool = PRESENT(xij)
+IF (abool) nsd = SIZE(xij, 1)
+
+nrow = nsd + 1
+ncol = nips(1)
+
+CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=ii, ncol=jj)
IF (abool) THEN
- ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :))
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", to="BIUNIT")
+ CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), x1=xij(1:nsd, 1), &
+ x2=xij(1:nsd, 2), x3=xij(1:nsd, 3), ans=ans, &
+ from="U", to="T", nrow=ii, ncol=jj)
+
+ areal = JacobianTriangle(from="UNIT", to="TRIANGLE", xij=xij)
+
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
+
RETURN
+
END IF
-ans = temp_t
+astr = UpperCase(reftriangle(1:1))
+abool = astr == "B"
-IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
+IF (abool) THEN
+ CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), ans=ans, &
+ from="U", to="B", nrow=ii, ncol=jj)
-END PROCEDURE QuadraturePoint_Triangle1
+ areal = JacobianTriangle(from="UNIT", to="BIUNIT")
-!----------------------------------------------------------------------------
-! QuadraturePoint_Triangle2
-!----------------------------------------------------------------------------
+ DO CONCURRENT(ii=1:ncol)
+ ans(nrow, ii) = ans(nrow, ii) * areal
+ END DO
-MODULE PROCEDURE QuadraturePoint_Triangle2
-INTEGER(I4B) :: nsd
-REAL(DFP), ALLOCATABLE :: temp_t(:, :)
-TYPE(string) :: astr
-
-IF (nips(1) .LE. QuadratureNumberTriangleSolin(order=20_I4B)) THEN
- astr = TRIM(UpperCase(refTriangle))
- temp_t = QuadraturePointTriangleSolin(nips=nips)
-
- IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- ELSE
- nsd = 2_I4B
- END IF
-
- CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_t, 2, kind=I4B))
-
- IF (PRESENT(xij)) THEN
- ans(1:nsd, :) = FromUnitTriangle2Triangle( &
- & xin=temp_t(1:2, :), &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3))
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( &
- & from="UNIT", &
- & to="TRIANGLE", &
- & xij=xij)
- ELSE
- IF (astr%chars() .EQ. "BIUNIT") THEN
- ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :))
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle( &
- & from="UNIT", &
- & to="BIUNIT")
-
- ELSE
- ans = temp_t
- END IF
- END IF
-
- IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
-ELSE
- CALL Errormsg( &
- & msg="This routine should be called for economical"// &
- & " quadrature points only, otherwise call QuadraturePoint_Triangle1()", &
- & file=__FILE__, &
- & line=__LINE__, &
- & routine="QuadraturePoint_Triangle2()", &
- & unitNo=stdout)
RETURN
END IF
-END PROCEDURE QuadraturePoint_Triangle2
+
+END PROCEDURE QuadraturePoint_Triangle2_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90
index 2c5e7e9d8..2b580884c 100644
--- a/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/UltrasphericalPolynomialUtility@Methods.F90
@@ -16,7 +16,28 @@
!
SUBMODULE(UltrasphericalPolynomialUtility) Methods
-USE BaseMethod
+USE OrthogonalPolynomialUtility, ONLY: JacobiMatrix
+
+#ifdef USE_LAPACK95
+USE F95_Lapack, ONLY: STEV
+#endif
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE MiscUtility, ONLY: Factorial
+
+USE BaseType, ONLY: qp => TypeQuadratureOpt
+
+USE GlobalData, ONLY: pi
+
+USE JacobiPolynomialUtility, ONLY: JacobiGaussQuadrature, &
+ JacobiGaussRadauQuadrature, &
+ JacobiGaussLobattoQuadrature, &
+ JacobiJacobiMatrix, &
+ JacobiJacobiRadauMatrix, &
+ JacobiJacobiLobattoMatrix, &
+ JacobiZeros
+
IMPLICIT NONE
CONTAINS
@@ -254,12 +275,12 @@
END IF
!!
SELECT CASE (QuadType)
-CASE (Gauss)
+CASE (qp%Gauss)
!!
order = n
CALL UltrasphericalGaussQuadrature(n=order, lambda=lambda, pt=pt, wt=wt)
!!
-CASE (GaussRadau, GaussRadauLeft)
+CASE (qp%GaussRadau, qp%GaussRadauLeft)
!!
IF (inside) THEN
order = n
@@ -274,7 +295,7 @@
& n=order, pt=pt, wt=wt)
END IF
!!
-CASE (GaussRadauRight)
+CASE (qp%GaussRadauRight)
!!
IF (inside) THEN
order = n
@@ -288,7 +309,7 @@
& n=order, pt=pt, wt=wt)
END IF
!!
-CASE (GaussLobatto)
+CASE (qp%GaussLobatto)
!!
IF (inside) THEN
order = n
@@ -548,7 +569,7 @@
p(1:nrow, ii + 1) = ((r_ii + lambda - 1.0_DFP) * 2.0_DFP * x * p(1:nrow, ii) &
& - (2.0_DFP * lambda + r_ii - 2.0_DFP) * p(1:nrow, ii - 1)) &
- & / r_ii
+ & / r_ii
ans(1:nrow, ii + 1) = 2.0_DFP * (r_ii + lambda - 1.0_DFP) * p(1:nrow, ii) &
& + ans(1:nrow, ii - 1)
@@ -839,80 +860,131 @@
!----------------------------------------------------------------------------
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)
-!!
+INTEGER(I4B) :: tsize
+CALL UltrasphericalTransform1_(n, lambda, coeff, x, w, quadType, ans, tsize)
+END PROCEDURE UltrasphericalTransform1
+
+!----------------------------------------------------------------------------
+! UltrasphericalTransform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE UltrasphericalTransform1_
+REAL(DFP) :: nrmsqr, areal, rn
+REAL(DFP), ALLOCATABLE :: PP(:, :)
+INTEGER(I4B) :: ii, jj, nips
+nips = SIZE(coeff)
+ALLOCATE (PP(nips, n + 1))
+
+tsize = n + 1
+
+CALL UltrasphericalEvalAll_(n=n, lambda=lambda, x=x, ans=PP, nrow=ii, ncol=jj)
+
DO jj = 0, n
- temp = PP(:, jj) * w * coeff
- ans(jj) = SUM(temp) / nrmsqr(jj)
+ areal = 0.0_DFP
+
+ DO ii = 0, n
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+
+ nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda)
+ ans(jj) = areal / nrmsqr
+
END DO
-!!
-END PROCEDURE UltrasphericalTransform1
+
+IF (quadType .EQ. qp%GaussLobatto) THEN
+
+ areal = 0.0_DFP
+ jj = n
+ DO ii = 0, n
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+
+ rn = REAL(n, KIND=DFP)
+ nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr
+
+ ans(jj) = areal / nrmsqr
+
+END IF
+
+DEALLOCATE (PP)
+
+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)
+MODULE PROCEDURE UltrasphericalTransform4_
+REAL(DFP) :: nrmsqr, areal, rn
+INTEGER(I4B) :: jj, ii, nips
+LOGICAL(LGT) :: abool
+
+tsize = n + 1
+nips = SIZE(coeff)
+
+DO jj = 0, n
+ areal = 0.0_DFP
+
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
END DO
+
+ nrmsqr = UltrasphericalNormSQR(n=jj, lambda=lambda)
+ ans(jj) = areal / nrmsqr
+
END DO
-!!
-END PROCEDURE UltrasphericalTransform2
+
+abool = (quadType .EQ. qp%GaussLobatto) .AND. (nips .EQ. n + 1)
+
+IF (abool) THEN
+
+ areal = 0.0_DFP
+ jj = n
+ DO ii = 0, nips - 1
+ areal = areal + PP(ii, jj) * w(ii) * coeff(ii)
+ END DO
+
+ rn = REAL(n, KIND=DFP)
+ nrmsqr = 2.0_DFP * (rn + lambda) / rn * nrmsqr
+
+ ans(jj) = areal / nrmsqr
+
+END IF
+
+END PROCEDURE UltrasphericalTransform4_
!----------------------------------------------------------------------------
! UltrasphericalTransform
!----------------------------------------------------------------------------
MODULE PROCEDURE UltrasphericalTransform3
-REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n)
+INTEGER(I4B) :: tsize
+CALL UltrasphericalTransform3_(n=n, lambda=lambda, x1=x1, x2=x2, f=f, &
+ ans=ans, tsize=tsize, quadType=quadType)
+END PROCEDURE UltrasphericalTransform3
+
+!----------------------------------------------------------------------------
+! UltrasphericalTransform
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE UltrasphericalTransform3_
+REAL(DFP) :: pt(0:n), wt(0:n), coeff(0:n), x
+REAL(DFP), PARAMETER :: one = 1.0_DFP, half = 0.5_DFP
INTEGER(I4B) :: ii
-CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt,&
- & quadType=quadType)
+CALL UltrasphericalQuadrature(n=n + 1, lambda=lambda, pt=pt, wt=wt, &
+ quadType=quadType)
DO ii = 0, n
- coeff(ii) = f(pt(ii))
+ x = (one - pt(ii)) * x1 + (one + pt(ii)) * x2
+ x = x * half
+ coeff(ii) = f(x)
END DO
-ans = UltrasphericalTransform(n=n, lambda=lambda, coeff=coeff, x=pt, &
- & w=wt, quadType=quadType)
+CALL UltrasphericalTransform_(n=n, lambda=lambda, coeff=coeff, x=pt, &
+ w=wt, quadType=quadType, ans=ans, tsize=tsize)
-END PROCEDURE UltrasphericalTransform3
+END PROCEDURE UltrasphericalTransform3_
!----------------------------------------------------------------------------
! UltrasphericalInvTransform
@@ -962,12 +1034,10 @@
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)
+CASE (qp%GaussLobatto)
+ CALL UltrasphericalDMatrixGL2(n=n, lambda=lambda, x=x, D=ans)
+CASE (qp%Gauss)
+ CALL UltrasphericalDMatrixG2(n=n, lambda=lambda, x=x, D=ans)
END SELECT
END PROCEDURE UltrasphericalDMatrix1
diff --git a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90
index 9092e9e12..92a324a16 100644
--- a/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90
+++ b/src/submodules/Polynomial/src/UnscaledLobattoPolynomialUtility@Methods.F90
@@ -118,54 +118,87 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE UnscaledLobattoEvalAll1
+INTEGER(I4B) :: tsize
+CALL UnscaledLobattoEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE UnscaledLobattoEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE UnscaledLobattoEvalAll1_
REAL(DFP) :: avar, m
REAL(DFP) :: p(n + 1)
INTEGER(I4B) :: ii
- !!
+
+tsize = n + 1
+
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)
+
+ CALL LegendreEvalAll_(n=n, x=x, ans=p, tsize=ii)
+
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
+END PROCEDURE UnscaledLobattoEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE UnscaledLobattoEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL UnscaledLobattoEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE UnscaledLobattoEvalAll2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE UnscaledLobattoEvalAll2_
REAL(DFP) :: avar, m
REAL(DFP) :: p(SIZE(x), n + 1)
-INTEGER(I4B) :: ii
- !!
+INTEGER(I4B) :: ii, aint, bint
+
+nrow = SIZE(x)
+ncol = n + 1
+
SELECT CASE (n)
CASE (0)
- ans(:, 1) = 0.5_DFP * (1.0_DFP - x)
+ ans(1:nrow, 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)
+ ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x)
+ ans(1:nrow, 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)
+ ans(1:nrow, 1) = 0.5_DFP * (1.0_DFP - x)
+ ans(1:nrow, 2) = 0.5_DFP * (1.0_DFP + x)
+
+ CALL LegendreEvalAll_(n=n, x=x, ans=p, nrow=aint, ncol=bint)
+
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))
+ ans(1:nrow, 2 + ii) = avar * (p(1:nrow, ii + 2) - p(1:nrow, ii))
END DO
+
END SELECT
-END PROCEDURE UnscaledLobattoEvalAll2
+END PROCEDURE UnscaledLobattoEvalAll2_
!----------------------------------------------------------------------------
!
@@ -218,56 +251,88 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE UnscaledLobattoGradientEvalAll1
+INTEGER(I4B) :: tsize
+CALL UnscaledLobattoGradientEvalAll1_(n=n, x=x, ans=ans, tsize=tsize)
+END PROCEDURE UnscaledLobattoGradientEvalAll1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE UnscaledLobattoGradientEvalAll1_
REAL(DFP) :: p(n)
INTEGER(I4B) :: ii
- !!
+
+tsize = n + 1
+
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)
- !!
+
+ ! p = LegendreEvalAll(n=n - 1_I4B, x=x)
+ CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, tsize=ii)
+
DO ii = 1, n - 1
ans(ii + 2) = p(ii + 1)
! ans(3:) = p(2:)
END DO
- !!
+
END SELECT
-END PROCEDURE UnscaledLobattoGradientEvalAll1
+
+END PROCEDURE UnscaledLobattoGradientEvalAll1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
MODULE PROCEDURE UnscaledLobattoGradientEvalAll2
+INTEGER(I4B) :: nrow, ncol
+CALL UnscaledLobattoGradientEvalAll2_(n=n, x=x, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+END PROCEDURE UnscaledLobattoGradientEvalAll2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE UnscaledLobattoGradientEvalAll2_
REAL(DFP) :: p(SIZE(x), n)
INTEGER(I4B) :: ii
- !!
+
+nrow = SIZE(x)
+ncol = n + 1
+
SELECT CASE (n)
CASE (0)
- ans(:, 1) = -0.5_DFP
+ ans(1:nrow, 1) = -0.5_DFP
+
CASE (1)
- ans(:, 1) = -0.5_DFP
- ans(:, 2) = 0.5_DFP
+ ans(1:nrow, 1) = -0.5_DFP
+ ans(1:nrow, 2) = 0.5_DFP
+
CASE DEFAULT
- ans(:, 1) = -0.5_DFP
- ans(:, 2) = 0.5_DFP
- !!
- p = LegendreEvalAll(n=n - 1_I4B, x=x)
- !!
+ ans(1:nrow, 1) = -0.5_DFP
+ ans(1:nrow, 2) = 0.5_DFP
+
+ ! p = LegendreEvalAll(n=n - 1_I4B, x=x)
+ CALL LegendreEvalAll_(n=n - 1_I4B, x=x, ans=p, nrow=nrow, ncol=ii)
+
DO ii = 1, n - 1
- ans(:, ii + 2) = p(:, ii + 1)
+ ans(1:nrow, ii + 2) = p(1:nrow, ii + 1)
! ans(3:) = p(2:)
END DO
!!
END SELECT
-END PROCEDURE UnscaledLobattoGradientEvalAll2
+END PROCEDURE UnscaledLobattoGradientEvalAll2_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90
new file mode 100644
index 000000000..c787dfffe
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order1.F90
@@ -0,0 +1,14 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order1(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ nrow = 4
+ ncol = 1
+
+ ans(1, 1) = 0.250000000000000
+ ans(2, 1) = 0.250000000000000
+ ans(3, 1) = 0.250000000000000
+ ans(4, 1) = 0.166666666666667
+
+END SUBROUTINE QP_Tetrahedron_Order1
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90
new file mode 100644
index 000000000..a82c7d727
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order10.F90
@@ -0,0 +1,10 @@
+PURE SUBROUTINE QP_Tetrahedron_Order10(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 126)
+ nrow = 4; ncol = 126
+
+ CALL QP_Tetrahedron_Order11(ans, nrow, ncol)
+
+END SUBROUTINE QP_Tetrahedron_Order10
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90
new file mode 100644
index 000000000..b91e8d3ca
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order11.F90
@@ -0,0 +1,135 @@
+PURE subroutine QP_Tetrahedron_Order11(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 126)
+ nrow=4;ncol= 126
+
+ans(1:nrow, 1) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.045362824065000 ]
+ans(1:nrow, 2) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.045362824065000 ]
+ans(1:nrow, 3) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.045362824065000 ]
+ans(1:nrow, 4) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 5) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 6) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 7) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.045362824065000 ]
+ans(1:nrow, 8) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.045362824065000 ]
+ans(1:nrow, 9) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 10) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 11) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 12) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.045362824065000 ]
+ans(1:nrow, 13) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 14) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 15) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 16) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 17) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 18) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 19) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 20) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 21) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 22) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.045362824065000 ]
+ans(1:nrow, 23) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.045362824065000 ]
+ans(1:nrow, 24) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 25) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 26) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 27) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.045362824065000 ]
+ans(1:nrow, 28) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 29) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 30) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 31) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 32) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 33) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 34) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 35) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 36) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 37) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.045362824065000 ]
+ans(1:nrow, 38) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 39) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 40) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 41) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 42) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 43) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 44) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 45) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 46) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 47) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.045362824065000 ]
+ans(1:nrow, 48) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 49) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 50) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 51) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 52) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 53) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.045362824065000 ]
+ans(1:nrow, 54) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 55) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 56) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.045362824065000 ]
+ans(1:nrow, 57) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.116523476523500 ]
+ans(1:nrow, 58) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.116523476523500 ]
+ans(1:nrow, 59) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.116523476523500 ]
+ans(1:nrow, 60) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 61) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 62) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.116523476523500 ]
+ans(1:nrow, 63) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.116523476523500 ]
+ans(1:nrow, 64) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 65) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 66) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.116523476523500 ]
+ans(1:nrow, 67) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 68) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 69) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 70) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 71) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 72) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.116523476523500 ]
+ans(1:nrow, 73) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.116523476523500 ]
+ans(1:nrow, 74) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 75) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 76) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.116523476523500 ]
+ans(1:nrow, 77) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 78) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 79) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 80) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 81) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 82) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.116523476523500 ]
+ans(1:nrow, 83) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 84) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 85) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 86) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 87) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 88) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.116523476523500 ]
+ans(1:nrow, 89) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 90) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 91) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.116523476523500 ]
+ans(1:nrow, 92) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.101937289979833 ]
+ans(1:nrow, 93) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.101937289979833 ]
+ans(1:nrow, 94) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.101937289979833 ]
+ans(1:nrow, 95) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 96) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833 ]
+ans(1:nrow, 97) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833 ]
+ans(1:nrow, 98) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 99) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833 ]
+ans(1:nrow, 100) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 101) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 102) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.101937289979833 ]
+ans(1:nrow, 103) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.101937289979833 ]
+ans(1:nrow, 104) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 105) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833 ]
+ans(1:nrow, 106) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 107) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 108) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.101937289979833 ]
+ans(1:nrow, 109) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 110) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 111) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.101937289979833 ]
+ans(1:nrow, 112) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.035025386136500 ]
+ans(1:nrow, 113) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.035025386136500 ]
+ans(1:nrow, 114) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.035025386136500 ]
+ans(1:nrow, 115) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500 ]
+ans(1:nrow, 116) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500 ]
+ans(1:nrow, 117) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500 ]
+ans(1:nrow, 118) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.035025386136500 ]
+ans(1:nrow, 119) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.035025386136500 ]
+ans(1:nrow, 120) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500 ]
+ans(1:nrow, 121) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.035025386136500 ]
+ans(1:nrow, 122) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.004068080357150 ]
+ans(1:nrow, 123) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.004068080357150 ]
+ans(1:nrow, 124) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.004068080357150 ]
+ans(1:nrow, 125) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.004068080357150 ]
+ans(1:nrow, 126) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -9.062316284e-05 ]
+
+END subroutine QP_Tetrahedron_Order11
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90
new file mode 100644
index 000000000..2f5998ce2
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order12.F90
@@ -0,0 +1,10 @@
+PURE SUBROUTINE QP_Tetrahedron_Order12(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 210)
+ nrow = 4; ncol = 210
+
+ CALL QP_Tetrahedron_Order13(ans, nrow, ncol)
+
+END SUBROUTINE QP_Tetrahedron_Order12
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90
new file mode 100644
index 000000000..9069c47b6
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order13.F90
@@ -0,0 +1,220 @@
+PURE subroutine QP_Tetrahedron_Order13(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 210)
+ nrow=4;ncol= 210
+
+ans(1:nrow, 1) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.052550909016500 ]
+ans(1:nrow, 2) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.052550909016500 ]
+ans(1:nrow, 3) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.052550909016500 ]
+ans(1:nrow, 4) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 5) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 6) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 7) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 8) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500 ]
+ans(1:nrow, 9) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500 ]
+ans(1:nrow, 10) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 11) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 12) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 13) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 14) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500 ]
+ans(1:nrow, 15) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 16) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 17) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 18) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 19) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 20) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 21) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 22) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 23) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 24) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 25) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 26) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 27) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 28) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 29) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.052550909016500 ]
+ans(1:nrow, 30) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.052550909016500 ]
+ans(1:nrow, 31) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 32) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 33) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 34) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 35) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500 ]
+ans(1:nrow, 36) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 37) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 38) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 39) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 40) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 41) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 42) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 43) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 44) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 45) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 46) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 47) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 48) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 49) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 50) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.052550909016500 ]
+ans(1:nrow, 51) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 52) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 53) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 54) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 55) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 56) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 57) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 58) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 59) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 60) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 61) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 62) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 63) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 64) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 65) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.052550909016500 ]
+ans(1:nrow, 66) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 67) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 68) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 69) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 70) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 71) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 72) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 73) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 74) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 75) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.052550909016500 ]
+ans(1:nrow, 76) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 77) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 78) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 79) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 80) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 81) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.052550909016500 ]
+ans(1:nrow, 82) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 83) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 84) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.052550909016500 ]
+ans(1:nrow, 85) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.148185225279333 ]
+ans(1:nrow, 86) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.148185225279333 ]
+ans(1:nrow, 87) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.148185225279333 ]
+ans(1:nrow, 88) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 89) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 90) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 91) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.148185225279333 ]
+ans(1:nrow, 92) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.148185225279333 ]
+ans(1:nrow, 93) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 94) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 95) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 96) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.148185225279333 ]
+ans(1:nrow, 97) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 98) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 99) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 100) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 101) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 102) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 103) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 104) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 105) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 106) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.148185225279333 ]
+ans(1:nrow, 107) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.148185225279333 ]
+ans(1:nrow, 108) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 109) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 110) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 111) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.148185225279333 ]
+ans(1:nrow, 112) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 113) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 114) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 115) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 116) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 117) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 118) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 119) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 120) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 121) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.148185225279333 ]
+ans(1:nrow, 122) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 123) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 124) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 125) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 126) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 127) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 128) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 129) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 130) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 131) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.148185225279333 ]
+ans(1:nrow, 132) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 133) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 134) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 135) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 136) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 137) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.148185225279333 ]
+ans(1:nrow, 138) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 139) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 140) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.148185225279333 ]
+ans(1:nrow, 141) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.149815898387333 ]
+ans(1:nrow, 142) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.149815898387333 ]
+ans(1:nrow, 143) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.149815898387333 ]
+ans(1:nrow, 144) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 145) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 146) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.149815898387333 ]
+ans(1:nrow, 147) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.149815898387333 ]
+ans(1:nrow, 148) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 149) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 150) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.149815898387333 ]
+ans(1:nrow, 151) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 152) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 153) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 154) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 155) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 156) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.149815898387333 ]
+ans(1:nrow, 157) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.149815898387333 ]
+ans(1:nrow, 158) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 159) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 160) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.149815898387333 ]
+ans(1:nrow, 161) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 162) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 163) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 164) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 165) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 166) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.149815898387333 ]
+ans(1:nrow, 167) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 168) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 169) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 170) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 171) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 172) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.149815898387333 ]
+ans(1:nrow, 173) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 174) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 175) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.149815898387333 ]
+ans(1:nrow, 176) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.065344416653667 ]
+ans(1:nrow, 177) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.065344416653667 ]
+ans(1:nrow, 178) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.065344416653667 ]
+ans(1:nrow, 179) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 180) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667 ]
+ans(1:nrow, 181) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667 ]
+ans(1:nrow, 182) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 183) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667 ]
+ans(1:nrow, 184) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 185) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 186) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.065344416653667 ]
+ans(1:nrow, 187) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.065344416653667 ]
+ans(1:nrow, 188) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 189) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667 ]
+ans(1:nrow, 190) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 191) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 192) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.065344416653667 ]
+ans(1:nrow, 193) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 194) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 195) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.065344416653667 ]
+ans(1:nrow, 196) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.011675128712167 ]
+ans(1:nrow, 197) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.011675128712167 ]
+ans(1:nrow, 198) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.011675128712167 ]
+ans(1:nrow, 199) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167 ]
+ans(1:nrow, 200) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167 ]
+ans(1:nrow, 201) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167 ]
+ans(1:nrow, 202) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.011675128712167 ]
+ans(1:nrow, 203) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.011675128712167 ]
+ans(1:nrow, 204) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167 ]
+ans(1:nrow, 205) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.011675128712167 ]
+ans(1:nrow, 206) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.000665685876623 ]
+ans(1:nrow, 207) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.000665685876623 ]
+ans(1:nrow, 208) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.000665685876623 ]
+ans(1:nrow, 209) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.000665685876623 ]
+ans(1:nrow, 210) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +6.270821086e-06 ]
+
+END subroutine QP_Tetrahedron_Order13
+
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90
new file mode 100644
index 000000000..007cf086d
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order14.F90
@@ -0,0 +1,10 @@
+PURE SUBROUTINE QP_Tetrahedron_Order14(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 330)
+ nrow = 4; ncol = 330
+
+ CALL QP_Tetrahedron_Order15(ans, nrow, ncol)
+
+END SUBROUTINE QP_Tetrahedron_Order14
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90
new file mode 100644
index 000000000..3d8499718
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order15.F90
@@ -0,0 +1,339 @@
+PURE subroutine QP_Tetrahedron_Order15(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 330)
+ nrow=4;ncol= 330
+
+ans(1:nrow, 1) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.064317124103667 ]
+ans(1:nrow, 2) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.064317124103667 ]
+ans(1:nrow, 3) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.064317124103667 ]
+ans(1:nrow, 4) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 5) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 6) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 7) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 8) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 9) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.064317124103667 ]
+ans(1:nrow, 10) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.064317124103667 ]
+ans(1:nrow, 11) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 12) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 13) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 14) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 15) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 16) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.064317124103667 ]
+ans(1:nrow, 17) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 18) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 19) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 20) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 21) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 22) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 23) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 24) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 25) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 26) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 27) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 28) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 29) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 30) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 31) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 32) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 33) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 34) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 35) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 36) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 37) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.064317124103667 ]
+ans(1:nrow, 38) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.064317124103667 ]
+ans(1:nrow, 39) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 40) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 41) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 42) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 43) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 44) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.064317124103667 ]
+ans(1:nrow, 45) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 46) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 47) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 48) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 49) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 50) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 51) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 52) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 53) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 54) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 55) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 56) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 57) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 58) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 59) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 60) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 61) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 62) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 63) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 64) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 65) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.064317124103667 ]
+ans(1:nrow, 66) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 67) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 68) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 69) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 70) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 71) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 72) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 73) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 74) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 75) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 76) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 77) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 78) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 79) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 80) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 81) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 82) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 83) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 84) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 85) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 86) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.064317124103667 ]
+ans(1:nrow, 87) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 88) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 89) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 90) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 91) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 92) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 93) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 94) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 95) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 96) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 97) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 98) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 99) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 100) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 101) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.064317124103667 ]
+ans(1:nrow, 102) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 103) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 104) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 105) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 106) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 107) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 108) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 109) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 110) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 111) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.064317124103667 ]
+ans(1:nrow, 112) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 113) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 114) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 115) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 116) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 117) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.064317124103667 ]
+ans(1:nrow, 118) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 119) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 120) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.064317124103667 ]
+ans(1:nrow, 121) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.197838716296667 ]
+ans(1:nrow, 122) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.197838716296667 ]
+ans(1:nrow, 123) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.197838716296667 ]
+ans(1:nrow, 124) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 125) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 126) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 127) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 128) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667 ]
+ans(1:nrow, 129) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667 ]
+ans(1:nrow, 130) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 131) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 132) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 133) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 134) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667 ]
+ans(1:nrow, 135) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 136) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 137) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 138) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 139) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 140) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 141) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 142) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 143) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 144) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 145) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 146) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 147) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 148) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 149) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.197838716296667 ]
+ans(1:nrow, 150) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.197838716296667 ]
+ans(1:nrow, 151) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 152) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 153) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 154) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 155) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667 ]
+ans(1:nrow, 156) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 157) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 158) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 159) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 160) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 161) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 162) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 163) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 164) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 165) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 166) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 167) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 168) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 169) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 170) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.197838716296667 ]
+ans(1:nrow, 171) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 172) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 173) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 174) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 175) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 176) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 177) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 178) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 179) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 180) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 181) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 182) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 183) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 184) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 185) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.197838716296667 ]
+ans(1:nrow, 186) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 187) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 188) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 189) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 190) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 191) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 192) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 193) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 194) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 195) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.197838716296667 ]
+ans(1:nrow, 196) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 197) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 198) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 199) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 200) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 201) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.197838716296667 ]
+ans(1:nrow, 202) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 203) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 204) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.197838716296667 ]
+ans(1:nrow, 205) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.226908626208333 ]
+ans(1:nrow, 206) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.226908626208333 ]
+ans(1:nrow, 207) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.226908626208333 ]
+ans(1:nrow, 208) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 209) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 210) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 211) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.226908626208333 ]
+ans(1:nrow, 212) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.226908626208333 ]
+ans(1:nrow, 213) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 214) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 215) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 216) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.226908626208333 ]
+ans(1:nrow, 217) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 218) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 219) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 220) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 221) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 222) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 223) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 224) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 225) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 226) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.226908626208333 ]
+ans(1:nrow, 227) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.226908626208333 ]
+ans(1:nrow, 228) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 229) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 230) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 231) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.226908626208333 ]
+ans(1:nrow, 232) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 233) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 234) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 235) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 236) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 237) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 238) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 239) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 240) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 241) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.226908626208333 ]
+ans(1:nrow, 242) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 243) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 244) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 245) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 246) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 247) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 248) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 249) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 250) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 251) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.226908626208333 ]
+ans(1:nrow, 252) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 253) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 254) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 255) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 256) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 257) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.226908626208333 ]
+ans(1:nrow, 258) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 259) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 260) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.226908626208333 ]
+ans(1:nrow, 261) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.119852718709833 ]
+ans(1:nrow, 262) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.119852718709833 ]
+ans(1:nrow, 263) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.119852718709833 ]
+ans(1:nrow, 264) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 265) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 266) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.119852718709833 ]
+ans(1:nrow, 267) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.119852718709833 ]
+ans(1:nrow, 268) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 269) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 270) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.119852718709833 ]
+ans(1:nrow, 271) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 272) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 273) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 274) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 275) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 276) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.119852718709833 ]
+ans(1:nrow, 277) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.119852718709833 ]
+ans(1:nrow, 278) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 279) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 280) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.119852718709833 ]
+ans(1:nrow, 281) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 282) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 283) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 284) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 285) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 286) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.119852718709833 ]
+ans(1:nrow, 287) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 288) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 289) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 290) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 291) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 292) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.119852718709833 ]
+ans(1:nrow, 293) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 294) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 295) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.119852718709833 ]
+ans(1:nrow, 296) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.029171614577500 ]
+ans(1:nrow, 297) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.029171614577500 ]
+ans(1:nrow, 298) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.029171614577500 ]
+ans(1:nrow, 299) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 300) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500 ]
+ans(1:nrow, 301) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500 ]
+ans(1:nrow, 302) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 303) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500 ]
+ans(1:nrow, 304) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 305) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 306) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.029171614577500 ]
+ans(1:nrow, 307) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.029171614577500 ]
+ans(1:nrow, 308) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 309) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500 ]
+ans(1:nrow, 310) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 311) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 312) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.029171614577500 ]
+ans(1:nrow, 313) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 314) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 315) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.029171614577500 ]
+ans(1:nrow, 316) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , -0.002873877836833 ]
+ans(1:nrow, 317) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , -0.002873877836833 ]
+ans(1:nrow, 318) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , -0.002873877836833 ]
+ans(1:nrow, 319) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833 ]
+ans(1:nrow, 320) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833 ]
+ans(1:nrow, 321) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833 ]
+ans(1:nrow, 322) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , -0.002873877836833 ]
+ans(1:nrow, 323) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , -0.002873877836833 ]
+ans(1:nrow, 324) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833 ]
+ans(1:nrow, 325) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , -0.002873877836833 ]
+ans(1:nrow, 326) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +8.3210734578e-05 ]
+ans(1:nrow, 327) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +8.3210734578e-05 ]
+ans(1:nrow, 328) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05 ]
+ans(1:nrow, 329) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +8.3210734578e-05 ]
+ans(1:nrow, 330) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -3.25756939e-07 ]
+
+END subroutine QP_Tetrahedron_Order15
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90
new file mode 100644
index 000000000..dcbf7801d
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order16.F90
@@ -0,0 +1,10 @@
+PURE SUBROUTINE QP_Tetrahedron_Order16(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 495)
+ nrow = 4; ncol = 495
+
+ CALL QP_Tetrahedron_Order17(ans, nrow, ncol)
+
+END SUBROUTINE QP_Tetrahedron_Order16
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90
new file mode 100644
index 000000000..e9285b136
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order17.F90
@@ -0,0 +1,506 @@
+PURE subroutine QP_Tetrahedron_Order17(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 495)
+ nrow=4;ncol= 495
+
+ans(1:nrow, 1) = [ 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.082206352466167 ]
+ans(1:nrow, 2) = [ 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.082206352466167 ]
+ans(1:nrow, 3) = [ 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.082206352466167 ]
+ans(1:nrow, 4) = [ 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 5) = [ 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 6) = [ 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 7) = [ 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 8) = [ 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 9) = [ 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 10) = [ 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167 ]
+ans(1:nrow, 11) = [ 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167 ]
+ans(1:nrow, 12) = [ 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 13) = [ 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 14) = [ 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 15) = [ 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 16) = [ 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 17) = [ 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 18) = [ 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167 ]
+ans(1:nrow, 19) = [ 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 20) = [ 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 21) = [ 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 22) = [ 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 23) = [ 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 24) = [ 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 25) = [ 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 26) = [ 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 27) = [ 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 28) = [ 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 29) = [ 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 30) = [ 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 31) = [ 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 32) = [ 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 33) = [ 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 34) = [ 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 35) = [ 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 36) = [ 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 37) = [ 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 38) = [ 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 39) = [ 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 40) = [ 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 41) = [ 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 42) = [ 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 43) = [ 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 44) = [ 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 45) = [ 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 46) = [ 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.082206352466167 ]
+ans(1:nrow, 47) = [ 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.082206352466167 ]
+ans(1:nrow, 48) = [ 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 49) = [ 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 50) = [ 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 51) = [ 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 52) = [ 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 53) = [ 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 54) = [ 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167 ]
+ans(1:nrow, 55) = [ 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 56) = [ 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 57) = [ 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 58) = [ 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 59) = [ 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 60) = [ 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 61) = [ 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 62) = [ 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 63) = [ 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 64) = [ 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 65) = [ 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 66) = [ 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 67) = [ 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 68) = [ 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 69) = [ 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 70) = [ 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 71) = [ 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 72) = [ 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 73) = [ 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 74) = [ 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 75) = [ 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 76) = [ 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 77) = [ 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 78) = [ 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 79) = [ 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 80) = [ 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 81) = [ 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 82) = [ 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.082206352466167 ]
+ans(1:nrow, 83) = [ 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 84) = [ 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 85) = [ 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 86) = [ 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 87) = [ 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 88) = [ 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 89) = [ 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 90) = [ 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 91) = [ 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 92) = [ 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 93) = [ 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 94) = [ 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 95) = [ 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 96) = [ 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 97) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 98) = [ 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 99) = [ 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 100) = [ 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 101) = [ 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 102) = [ 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 103) = [ 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 104) = [ 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 105) = [ 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 106) = [ 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 107) = [ 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 108) = [ 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 109) = [ 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 110) = [ 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.082206352466167 ]
+ans(1:nrow, 111) = [ 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 112) = [ 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 113) = [ 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 114) = [ 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 115) = [ 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 116) = [ 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 117) = [ 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 118) = [ 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 119) = [ 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 120) = [ 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 121) = [ 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 122) = [ 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 123) = [ 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 124) = [ 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 125) = [ 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 126) = [ 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 127) = [ 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 128) = [ 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 129) = [ 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 130) = [ 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 131) = [ 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.082206352466167 ]
+ans(1:nrow, 132) = [ 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 133) = [ 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 134) = [ 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 135) = [ 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 136) = [ 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 137) = [ 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 138) = [ 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 139) = [ 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 140) = [ 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 141) = [ 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 142) = [ 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 143) = [ 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 144) = [ 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 145) = [ 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 146) = [ 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.082206352466167 ]
+ans(1:nrow, 147) = [ 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 148) = [ 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 149) = [ 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 150) = [ 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 151) = [ 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 152) = [ 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 153) = [ 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 154) = [ 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 155) = [ 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 156) = [ 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.082206352466167 ]
+ans(1:nrow, 157) = [ 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 158) = [ 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 159) = [ 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 160) = [ 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 161) = [ 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 162) = [ 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.082206352466167 ]
+ans(1:nrow, 163) = [ 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 164) = [ 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 165) = [ 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.082206352466167 ]
+ans(1:nrow, 166) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.274194055390000 ]
+ans(1:nrow, 167) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.274194055390000 ]
+ans(1:nrow, 168) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.274194055390000 ]
+ans(1:nrow, 169) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 170) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 171) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 172) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 173) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 174) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.274194055390000 ]
+ans(1:nrow, 175) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.274194055390000 ]
+ans(1:nrow, 176) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 177) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 178) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 179) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 180) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 181) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.274194055390000 ]
+ans(1:nrow, 182) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 183) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 184) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 185) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 186) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 187) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 188) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 189) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 190) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 191) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 192) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 193) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 194) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 195) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 196) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 197) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 198) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 199) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 200) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 201) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 202) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.274194055390000 ]
+ans(1:nrow, 203) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.274194055390000 ]
+ans(1:nrow, 204) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 205) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 206) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 207) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 208) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 209) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.274194055390000 ]
+ans(1:nrow, 210) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 211) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 212) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 213) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 214) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 215) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 216) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 217) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 218) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 219) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 220) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 221) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 222) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 223) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 224) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 225) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 226) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 227) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 228) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 229) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 230) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.274194055390000 ]
+ans(1:nrow, 231) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 232) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 233) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 234) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 235) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 236) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 237) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 238) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 239) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 240) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 241) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 242) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 243) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 244) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 245) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 246) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 247) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 248) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 249) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 250) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 251) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.274194055390000 ]
+ans(1:nrow, 252) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 253) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 254) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 255) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 256) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 257) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 258) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 259) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 260) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 261) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 262) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 263) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 264) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 265) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 266) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.274194055390000 ]
+ans(1:nrow, 267) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 268) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 269) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 270) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 271) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 272) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 273) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 274) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 275) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 276) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.274194055390000 ]
+ans(1:nrow, 277) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 278) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 279) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 280) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 281) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 282) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.274194055390000 ]
+ans(1:nrow, 283) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 284) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 285) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.274194055390000 ]
+ans(1:nrow, 286) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.351713273418333 ]
+ans(1:nrow, 287) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.351713273418333 ]
+ans(1:nrow, 288) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.351713273418333 ]
+ans(1:nrow, 289) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 290) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 291) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 292) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 293) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333 ]
+ans(1:nrow, 294) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333 ]
+ans(1:nrow, 295) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 296) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 297) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 298) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 299) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333 ]
+ans(1:nrow, 300) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 301) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 302) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 303) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 304) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 305) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 306) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 307) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 308) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 309) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 310) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 311) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 312) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 313) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 314) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.351713273418333 ]
+ans(1:nrow, 315) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.351713273418333 ]
+ans(1:nrow, 316) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 317) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 318) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 319) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 320) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333 ]
+ans(1:nrow, 321) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 322) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 323) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 324) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 325) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 326) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 327) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 328) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 329) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 330) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 331) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 332) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 333) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 334) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 335) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.351713273418333 ]
+ans(1:nrow, 336) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 337) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 338) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 339) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 340) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 341) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 342) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 343) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 344) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 345) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 346) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 347) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 348) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 349) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 350) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.351713273418333 ]
+ans(1:nrow, 351) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 352) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 353) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 354) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 355) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 356) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 357) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 358) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 359) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 360) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.351713273418333 ]
+ans(1:nrow, 361) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 362) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 363) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 364) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 365) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 366) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.351713273418333 ]
+ans(1:nrow, 367) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 368) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 369) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.351713273418333 ]
+ans(1:nrow, 370) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.218010248710000 ]
+ans(1:nrow, 371) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.218010248710000 ]
+ans(1:nrow, 372) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.218010248710000 ]
+ans(1:nrow, 373) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 374) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 375) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 376) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.218010248710000 ]
+ans(1:nrow, 377) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.218010248710000 ]
+ans(1:nrow, 378) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 379) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 380) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 381) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.218010248710000 ]
+ans(1:nrow, 382) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 383) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 384) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 385) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 386) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 387) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 388) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 389) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 390) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 391) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.218010248710000 ]
+ans(1:nrow, 392) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.218010248710000 ]
+ans(1:nrow, 393) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 394) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 395) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 396) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.218010248710000 ]
+ans(1:nrow, 397) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 398) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 399) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 400) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 401) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 402) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 403) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 404) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 405) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 406) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.218010248710000 ]
+ans(1:nrow, 407) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 408) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 409) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 410) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 411) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 412) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 413) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 414) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 415) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 416) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.218010248710000 ]
+ans(1:nrow, 417) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 418) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 419) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 420) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 421) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 422) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.218010248710000 ]
+ans(1:nrow, 423) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 424) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 425) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.218010248710000 ]
+ans(1:nrow, 426) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.067417154274333 ]
+ans(1:nrow, 427) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.067417154274333 ]
+ans(1:nrow, 428) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.067417154274333 ]
+ans(1:nrow, 429) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 430) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 431) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.067417154274333 ]
+ans(1:nrow, 432) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.067417154274333 ]
+ans(1:nrow, 433) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 434) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 435) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.067417154274333 ]
+ans(1:nrow, 436) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 437) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 438) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 439) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 440) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 441) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.067417154274333 ]
+ans(1:nrow, 442) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.067417154274333 ]
+ans(1:nrow, 443) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 444) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 445) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.067417154274333 ]
+ans(1:nrow, 446) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 447) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 448) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 449) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 450) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 451) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.067417154274333 ]
+ans(1:nrow, 452) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 453) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 454) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 455) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 456) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 457) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.067417154274333 ]
+ans(1:nrow, 458) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 459) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 460) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.067417154274333 ]
+ans(1:nrow, 461) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.009723871525850 ]
+ans(1:nrow, 462) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.009723871525850 ]
+ans(1:nrow, 463) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.009723871525850 ]
+ans(1:nrow, 464) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 465) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850 ]
+ans(1:nrow, 466) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850 ]
+ans(1:nrow, 467) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 468) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850 ]
+ans(1:nrow, 469) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 470) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 471) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.009723871525850 ]
+ans(1:nrow, 472) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.009723871525850 ]
+ans(1:nrow, 473) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 474) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850 ]
+ans(1:nrow, 475) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 476) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 477) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.009723871525850 ]
+ans(1:nrow, 478) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 479) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 480) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.009723871525850 ]
+ans(1:nrow, 481) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.000547405302255 ]
+ans(1:nrow, 482) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.000547405302255 ]
+ans(1:nrow, 483) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.000547405302255 ]
+ans(1:nrow, 484) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255 ]
+ans(1:nrow, 485) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255 ]
+ans(1:nrow, 486) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255 ]
+ans(1:nrow, 487) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.000547405302255 ]
+ans(1:nrow, 488) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.000547405302255 ]
+ans(1:nrow, 489) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255 ]
+ans(1:nrow, 490) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.000547405302255 ]
+ans(1:nrow, 491) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -8.22963309013e-06 ]
+ans(1:nrow, 492) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -8.22963309013e-06 ]
+ans(1:nrow, 493) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06 ]
+ans(1:nrow, 494) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -8.22963309013e-06 ]
+ans(1:nrow, 495) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.573205875e-08 ]
+
+END subroutine QP_Tetrahedron_Order17
+
+
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90
new file mode 100644
index 000000000..874e97f62
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order18.F90
@@ -0,0 +1,10 @@
+PURE SUBROUTINE QP_Tetrahedron_Order18(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 715)
+ nrow = 4; ncol = 715
+
+ CALL QP_Tetrahedron_Order19(ans, nrow, ncol)
+
+END SUBROUTINE QP_Tetrahedron_Order18
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90
new file mode 100644
index 000000000..76002848e
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order19.F90
@@ -0,0 +1,724 @@
+PURE subroutine QP_Tetrahedron_Order19(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 715)
+ nrow=4;ncol= 715
+
+ans(1:nrow, 1) = [ 0.0454545454545, 0.0454545454545, 0.8636363636360 , +0.108823933894333 ]
+ans(1:nrow, 2) = [ 0.0454545454545, 0.1363636363640, 0.7727272727270 , +0.108823933894333 ]
+ans(1:nrow, 3) = [ 0.0454545454545, 0.2272727272730, 0.6818181818180 , +0.108823933894333 ]
+ans(1:nrow, 4) = [ 0.0454545454545, 0.3181818181820, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 5) = [ 0.0454545454545, 0.4090909090910, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 6) = [ 0.0454545454545, 0.5000000000000, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 7) = [ 0.0454545454545, 0.5909090909090, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 8) = [ 0.0454545454545, 0.6818181818180, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 9) = [ 0.0454545454545, 0.7727272727270, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 10) = [ 0.0454545454545, 0.8636363636360, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 11) = [ 0.1363636363640, 0.0454545454545, 0.7727272727270 , +0.108823933894333 ]
+ans(1:nrow, 12) = [ 0.1363636363640, 0.1363636363640, 0.6818181818180 , +0.108823933894333 ]
+ans(1:nrow, 13) = [ 0.1363636363640, 0.2272727272730, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 14) = [ 0.1363636363640, 0.3181818181820, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 15) = [ 0.1363636363640, 0.4090909090910, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 16) = [ 0.1363636363640, 0.5000000000000, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 17) = [ 0.1363636363640, 0.5909090909090, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 18) = [ 0.1363636363640, 0.6818181818180, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 19) = [ 0.1363636363640, 0.7727272727270, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 20) = [ 0.2272727272730, 0.0454545454545, 0.6818181818180 , +0.108823933894333 ]
+ans(1:nrow, 21) = [ 0.2272727272730, 0.1363636363640, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 22) = [ 0.2272727272730, 0.2272727272730, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 23) = [ 0.2272727272730, 0.3181818181820, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 24) = [ 0.2272727272730, 0.4090909090910, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 25) = [ 0.2272727272730, 0.5000000000000, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 26) = [ 0.2272727272730, 0.5909090909090, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 27) = [ 0.2272727272730, 0.6818181818180, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 28) = [ 0.3181818181820, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 29) = [ 0.3181818181820, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 30) = [ 0.3181818181820, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 31) = [ 0.3181818181820, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 32) = [ 0.3181818181820, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 33) = [ 0.3181818181820, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 34) = [ 0.3181818181820, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 35) = [ 0.4090909090910, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 36) = [ 0.4090909090910, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 37) = [ 0.4090909090910, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 38) = [ 0.4090909090910, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 39) = [ 0.4090909090910, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 40) = [ 0.4090909090910, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 41) = [ 0.5000000000000, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 42) = [ 0.5000000000000, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 43) = [ 0.5000000000000, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 44) = [ 0.5000000000000, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 45) = [ 0.5000000000000, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 46) = [ 0.5909090909090, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 47) = [ 0.5909090909090, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 48) = [ 0.5909090909090, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 49) = [ 0.5909090909090, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 50) = [ 0.6818181818180, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 51) = [ 0.6818181818180, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 52) = [ 0.6818181818180, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 53) = [ 0.7727272727270, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 54) = [ 0.7727272727270, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 55) = [ 0.8636363636360, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 56) = [ 0.0454545454545, 0.0454545454545, 0.7727272727270 , +0.108823933894333 ]
+ans(1:nrow, 57) = [ 0.0454545454545, 0.1363636363640, 0.6818181818180 , +0.108823933894333 ]
+ans(1:nrow, 58) = [ 0.0454545454545, 0.2272727272730, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 59) = [ 0.0454545454545, 0.3181818181820, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 60) = [ 0.0454545454545, 0.4090909090910, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 61) = [ 0.0454545454545, 0.5000000000000, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 62) = [ 0.0454545454545, 0.5909090909090, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 63) = [ 0.0454545454545, 0.6818181818180, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 64) = [ 0.0454545454545, 0.7727272727270, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 65) = [ 0.1363636363640, 0.0454545454545, 0.6818181818180 , +0.108823933894333 ]
+ans(1:nrow, 66) = [ 0.1363636363640, 0.1363636363640, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 67) = [ 0.1363636363640, 0.2272727272730, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 68) = [ 0.1363636363640, 0.3181818181820, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 69) = [ 0.1363636363640, 0.4090909090910, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 70) = [ 0.1363636363640, 0.5000000000000, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 71) = [ 0.1363636363640, 0.5909090909090, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 72) = [ 0.1363636363640, 0.6818181818180, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 73) = [ 0.2272727272730, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 74) = [ 0.2272727272730, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 75) = [ 0.2272727272730, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 76) = [ 0.2272727272730, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 77) = [ 0.2272727272730, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 78) = [ 0.2272727272730, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 79) = [ 0.2272727272730, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 80) = [ 0.3181818181820, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 81) = [ 0.3181818181820, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 82) = [ 0.3181818181820, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 83) = [ 0.3181818181820, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 84) = [ 0.3181818181820, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 85) = [ 0.3181818181820, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 86) = [ 0.4090909090910, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 87) = [ 0.4090909090910, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 88) = [ 0.4090909090910, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 89) = [ 0.4090909090910, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 90) = [ 0.4090909090910, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 91) = [ 0.5000000000000, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 92) = [ 0.5000000000000, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 93) = [ 0.5000000000000, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 94) = [ 0.5000000000000, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 95) = [ 0.5909090909090, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 96) = [ 0.5909090909090, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 97) = [ 0.5909090909090, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 98) = [ 0.6818181818180, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 99) = [ 0.6818181818180, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 100) = [ 0.7727272727270, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 101) = [ 0.0454545454545, 0.0454545454545, 0.6818181818180 , +0.108823933894333 ]
+ans(1:nrow, 102) = [ 0.0454545454545, 0.1363636363640, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 103) = [ 0.0454545454545, 0.2272727272730, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 104) = [ 0.0454545454545, 0.3181818181820, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 105) = [ 0.0454545454545, 0.4090909090910, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 106) = [ 0.0454545454545, 0.5000000000000, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 107) = [ 0.0454545454545, 0.5909090909090, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 108) = [ 0.0454545454545, 0.6818181818180, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 109) = [ 0.1363636363640, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 110) = [ 0.1363636363640, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 111) = [ 0.1363636363640, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 112) = [ 0.1363636363640, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 113) = [ 0.1363636363640, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 114) = [ 0.1363636363640, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 115) = [ 0.1363636363640, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 116) = [ 0.2272727272730, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 117) = [ 0.2272727272730, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 118) = [ 0.2272727272730, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 119) = [ 0.2272727272730, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 120) = [ 0.2272727272730, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 121) = [ 0.2272727272730, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 122) = [ 0.3181818181820, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 123) = [ 0.3181818181820, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 124) = [ 0.3181818181820, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 125) = [ 0.3181818181820, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 126) = [ 0.3181818181820, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 127) = [ 0.4090909090910, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 128) = [ 0.4090909090910, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 129) = [ 0.4090909090910, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 130) = [ 0.4090909090910, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 131) = [ 0.5000000000000, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 132) = [ 0.5000000000000, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 133) = [ 0.5000000000000, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 134) = [ 0.5909090909090, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 135) = [ 0.5909090909090, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 136) = [ 0.6818181818180, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 137) = [ 0.0454545454545, 0.0454545454545, 0.5909090909090 , +0.108823933894333 ]
+ans(1:nrow, 138) = [ 0.0454545454545, 0.1363636363640, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 139) = [ 0.0454545454545, 0.2272727272730, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 140) = [ 0.0454545454545, 0.3181818181820, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 141) = [ 0.0454545454545, 0.4090909090910, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 142) = [ 0.0454545454545, 0.5000000000000, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 143) = [ 0.0454545454545, 0.5909090909090, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 144) = [ 0.1363636363640, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 145) = [ 0.1363636363640, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 146) = [ 0.1363636363640, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 147) = [ 0.1363636363640, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 148) = [ 0.1363636363640, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 149) = [ 0.1363636363640, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 150) = [ 0.2272727272730, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 151) = [ 0.2272727272730, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 152) = [ 0.2272727272730, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 153) = [ 0.2272727272730, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 154) = [ 0.2272727272730, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 155) = [ 0.3181818181820, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 156) = [ 0.3181818181820, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 157) = [ 0.3181818181820, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 158) = [ 0.3181818181820, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 159) = [ 0.4090909090910, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 160) = [ 0.4090909090910, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 161) = [ 0.4090909090910, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 162) = [ 0.5000000000000, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 163) = [ 0.5000000000000, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 164) = [ 0.5909090909090, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 165) = [ 0.0454545454545, 0.0454545454545, 0.5000000000000 , +0.108823933894333 ]
+ans(1:nrow, 166) = [ 0.0454545454545, 0.1363636363640, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 167) = [ 0.0454545454545, 0.2272727272730, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 168) = [ 0.0454545454545, 0.3181818181820, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 169) = [ 0.0454545454545, 0.4090909090910, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 170) = [ 0.0454545454545, 0.5000000000000, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 171) = [ 0.1363636363640, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 172) = [ 0.1363636363640, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 173) = [ 0.1363636363640, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 174) = [ 0.1363636363640, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 175) = [ 0.1363636363640, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 176) = [ 0.2272727272730, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 177) = [ 0.2272727272730, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 178) = [ 0.2272727272730, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 179) = [ 0.2272727272730, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 180) = [ 0.3181818181820, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 181) = [ 0.3181818181820, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 182) = [ 0.3181818181820, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 183) = [ 0.4090909090910, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 184) = [ 0.4090909090910, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 185) = [ 0.5000000000000, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 186) = [ 0.0454545454545, 0.0454545454545, 0.4090909090910 , +0.108823933894333 ]
+ans(1:nrow, 187) = [ 0.0454545454545, 0.1363636363640, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 188) = [ 0.0454545454545, 0.2272727272730, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 189) = [ 0.0454545454545, 0.3181818181820, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 190) = [ 0.0454545454545, 0.4090909090910, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 191) = [ 0.1363636363640, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 192) = [ 0.1363636363640, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 193) = [ 0.1363636363640, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 194) = [ 0.1363636363640, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 195) = [ 0.2272727272730, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 196) = [ 0.2272727272730, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 197) = [ 0.2272727272730, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 198) = [ 0.3181818181820, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 199) = [ 0.3181818181820, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 200) = [ 0.4090909090910, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 201) = [ 0.0454545454545, 0.0454545454545, 0.3181818181820 , +0.108823933894333 ]
+ans(1:nrow, 202) = [ 0.0454545454545, 0.1363636363640, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 203) = [ 0.0454545454545, 0.2272727272730, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 204) = [ 0.0454545454545, 0.3181818181820, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 205) = [ 0.1363636363640, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 206) = [ 0.1363636363640, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 207) = [ 0.1363636363640, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 208) = [ 0.2272727272730, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 209) = [ 0.2272727272730, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 210) = [ 0.3181818181820, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 211) = [ 0.0454545454545, 0.0454545454545, 0.2272727272730 , +0.108823933894333 ]
+ans(1:nrow, 212) = [ 0.0454545454545, 0.1363636363640, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 213) = [ 0.0454545454545, 0.2272727272730, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 214) = [ 0.1363636363640, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 215) = [ 0.1363636363640, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 216) = [ 0.2272727272730, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 217) = [ 0.0454545454545, 0.0454545454545, 0.1363636363640 , +0.108823933894333 ]
+ans(1:nrow, 218) = [ 0.0454545454545, 0.1363636363640, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 219) = [ 0.1363636363640, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 220) = [ 0.0454545454545, 0.0454545454545, 0.0454545454545 , +0.108823933894333 ]
+ans(1:nrow, 221) = [ 0.0500000000000, 0.0500000000000, 0.8500000000000 , -0.391458821268333 ]
+ans(1:nrow, 222) = [ 0.0500000000000, 0.1500000000000, 0.7500000000000 , -0.391458821268333 ]
+ans(1:nrow, 223) = [ 0.0500000000000, 0.2500000000000, 0.6500000000000 , -0.391458821268333 ]
+ans(1:nrow, 224) = [ 0.0500000000000, 0.3500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 225) = [ 0.0500000000000, 0.4500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 226) = [ 0.0500000000000, 0.5500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 227) = [ 0.0500000000000, 0.6500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 228) = [ 0.0500000000000, 0.7500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 229) = [ 0.0500000000000, 0.8500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 230) = [ 0.1500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333 ]
+ans(1:nrow, 231) = [ 0.1500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333 ]
+ans(1:nrow, 232) = [ 0.1500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 233) = [ 0.1500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 234) = [ 0.1500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 235) = [ 0.1500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 236) = [ 0.1500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 237) = [ 0.1500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 238) = [ 0.2500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333 ]
+ans(1:nrow, 239) = [ 0.2500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 240) = [ 0.2500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 241) = [ 0.2500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 242) = [ 0.2500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 243) = [ 0.2500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 244) = [ 0.2500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 245) = [ 0.3500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 246) = [ 0.3500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 247) = [ 0.3500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 248) = [ 0.3500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 249) = [ 0.3500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 250) = [ 0.3500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 251) = [ 0.4500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 252) = [ 0.4500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 253) = [ 0.4500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 254) = [ 0.4500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 255) = [ 0.4500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 256) = [ 0.5500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 257) = [ 0.5500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 258) = [ 0.5500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 259) = [ 0.5500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 260) = [ 0.6500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 261) = [ 0.6500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 262) = [ 0.6500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 263) = [ 0.7500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 264) = [ 0.7500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 265) = [ 0.8500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 266) = [ 0.0500000000000, 0.0500000000000, 0.7500000000000 , -0.391458821268333 ]
+ans(1:nrow, 267) = [ 0.0500000000000, 0.1500000000000, 0.6500000000000 , -0.391458821268333 ]
+ans(1:nrow, 268) = [ 0.0500000000000, 0.2500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 269) = [ 0.0500000000000, 0.3500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 270) = [ 0.0500000000000, 0.4500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 271) = [ 0.0500000000000, 0.5500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 272) = [ 0.0500000000000, 0.6500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 273) = [ 0.0500000000000, 0.7500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 274) = [ 0.1500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333 ]
+ans(1:nrow, 275) = [ 0.1500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 276) = [ 0.1500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 277) = [ 0.1500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 278) = [ 0.1500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 279) = [ 0.1500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 280) = [ 0.1500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 281) = [ 0.2500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 282) = [ 0.2500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 283) = [ 0.2500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 284) = [ 0.2500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 285) = [ 0.2500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 286) = [ 0.2500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 287) = [ 0.3500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 288) = [ 0.3500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 289) = [ 0.3500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 290) = [ 0.3500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 291) = [ 0.3500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 292) = [ 0.4500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 293) = [ 0.4500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 294) = [ 0.4500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 295) = [ 0.4500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 296) = [ 0.5500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 297) = [ 0.5500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 298) = [ 0.5500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 299) = [ 0.6500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 300) = [ 0.6500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 301) = [ 0.7500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 302) = [ 0.0500000000000, 0.0500000000000, 0.6500000000000 , -0.391458821268333 ]
+ans(1:nrow, 303) = [ 0.0500000000000, 0.1500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 304) = [ 0.0500000000000, 0.2500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 305) = [ 0.0500000000000, 0.3500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 306) = [ 0.0500000000000, 0.4500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 307) = [ 0.0500000000000, 0.5500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 308) = [ 0.0500000000000, 0.6500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 309) = [ 0.1500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 310) = [ 0.1500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 311) = [ 0.1500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 312) = [ 0.1500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 313) = [ 0.1500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 314) = [ 0.1500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 315) = [ 0.2500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 316) = [ 0.2500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 317) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 318) = [ 0.2500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 319) = [ 0.2500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 320) = [ 0.3500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 321) = [ 0.3500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 322) = [ 0.3500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 323) = [ 0.3500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 324) = [ 0.4500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 325) = [ 0.4500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 326) = [ 0.4500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 327) = [ 0.5500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 328) = [ 0.5500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 329) = [ 0.6500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 330) = [ 0.0500000000000, 0.0500000000000, 0.5500000000000 , -0.391458821268333 ]
+ans(1:nrow, 331) = [ 0.0500000000000, 0.1500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 332) = [ 0.0500000000000, 0.2500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 333) = [ 0.0500000000000, 0.3500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 334) = [ 0.0500000000000, 0.4500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 335) = [ 0.0500000000000, 0.5500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 336) = [ 0.1500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 337) = [ 0.1500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 338) = [ 0.1500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 339) = [ 0.1500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 340) = [ 0.1500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 341) = [ 0.2500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 342) = [ 0.2500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 343) = [ 0.2500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 344) = [ 0.2500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 345) = [ 0.3500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 346) = [ 0.3500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 347) = [ 0.3500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 348) = [ 0.4500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 349) = [ 0.4500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 350) = [ 0.5500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 351) = [ 0.0500000000000, 0.0500000000000, 0.4500000000000 , -0.391458821268333 ]
+ans(1:nrow, 352) = [ 0.0500000000000, 0.1500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 353) = [ 0.0500000000000, 0.2500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 354) = [ 0.0500000000000, 0.3500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 355) = [ 0.0500000000000, 0.4500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 356) = [ 0.1500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 357) = [ 0.1500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 358) = [ 0.1500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 359) = [ 0.1500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 360) = [ 0.2500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 361) = [ 0.2500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 362) = [ 0.2500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 363) = [ 0.3500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 364) = [ 0.3500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 365) = [ 0.4500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 366) = [ 0.0500000000000, 0.0500000000000, 0.3500000000000 , -0.391458821268333 ]
+ans(1:nrow, 367) = [ 0.0500000000000, 0.1500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 368) = [ 0.0500000000000, 0.2500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 369) = [ 0.0500000000000, 0.3500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 370) = [ 0.1500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 371) = [ 0.1500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 372) = [ 0.1500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 373) = [ 0.2500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 374) = [ 0.2500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 375) = [ 0.3500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 376) = [ 0.0500000000000, 0.0500000000000, 0.2500000000000 , -0.391458821268333 ]
+ans(1:nrow, 377) = [ 0.0500000000000, 0.1500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 378) = [ 0.0500000000000, 0.2500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 379) = [ 0.1500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 380) = [ 0.1500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 381) = [ 0.2500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 382) = [ 0.0500000000000, 0.0500000000000, 0.1500000000000 , -0.391458821268333 ]
+ans(1:nrow, 383) = [ 0.0500000000000, 0.1500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 384) = [ 0.1500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 385) = [ 0.0500000000000, 0.0500000000000, 0.0500000000000 , -0.391458821268333 ]
+ans(1:nrow, 386) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , +0.555242962163333 ]
+ans(1:nrow, 387) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , +0.555242962163333 ]
+ans(1:nrow, 388) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , +0.555242962163333 ]
+ans(1:nrow, 389) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 390) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 391) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 392) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 393) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 394) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , +0.555242962163333 ]
+ans(1:nrow, 395) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , +0.555242962163333 ]
+ans(1:nrow, 396) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 397) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 398) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 399) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 400) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 401) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , +0.555242962163333 ]
+ans(1:nrow, 402) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 403) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 404) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 405) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 406) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 407) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 408) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 409) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 410) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 411) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 412) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 413) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 414) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 415) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 416) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 417) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 418) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 419) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 420) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 421) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 422) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , +0.555242962163333 ]
+ans(1:nrow, 423) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , +0.555242962163333 ]
+ans(1:nrow, 424) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 425) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 426) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 427) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 428) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 429) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , +0.555242962163333 ]
+ans(1:nrow, 430) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 431) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 432) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 433) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 434) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 435) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 436) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 437) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 438) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 439) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 440) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 441) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 442) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 443) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 444) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 445) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 446) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 447) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 448) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 449) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 450) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , +0.555242962163333 ]
+ans(1:nrow, 451) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 452) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 453) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 454) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 455) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 456) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 457) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 458) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 459) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 460) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 461) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 462) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 463) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 464) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 465) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 466) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 467) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 468) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 469) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 470) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 471) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , +0.555242962163333 ]
+ans(1:nrow, 472) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 473) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 474) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 475) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 476) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 477) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 478) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 479) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 480) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 481) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 482) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 483) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 484) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 485) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 486) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , +0.555242962163333 ]
+ans(1:nrow, 487) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 488) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 489) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 490) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 491) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 492) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 493) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 494) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 495) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 496) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , +0.555242962163333 ]
+ans(1:nrow, 497) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 498) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 499) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 500) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 501) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 502) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , +0.555242962163333 ]
+ans(1:nrow, 503) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 504) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 505) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , +0.555242962163333 ]
+ans(1:nrow, 506) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , -0.394906131556667 ]
+ans(1:nrow, 507) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , -0.394906131556667 ]
+ans(1:nrow, 508) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , -0.394906131556667 ]
+ans(1:nrow, 509) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 510) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 511) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 512) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 513) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667 ]
+ans(1:nrow, 514) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667 ]
+ans(1:nrow, 515) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 516) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 517) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 518) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 519) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667 ]
+ans(1:nrow, 520) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 521) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 522) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 523) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 524) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 525) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 526) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 527) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 528) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 529) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 530) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 531) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 532) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 533) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 534) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , -0.394906131556667 ]
+ans(1:nrow, 535) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , -0.394906131556667 ]
+ans(1:nrow, 536) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 537) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 538) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 539) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 540) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667 ]
+ans(1:nrow, 541) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 542) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 543) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 544) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 545) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 546) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 547) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 548) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 549) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 550) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 551) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 552) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 553) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 554) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 555) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , -0.394906131556667 ]
+ans(1:nrow, 556) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 557) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 558) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 559) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 560) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 561) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 562) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 563) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 564) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 565) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 566) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 567) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 568) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 569) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 570) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , -0.394906131556667 ]
+ans(1:nrow, 571) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 572) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 573) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 574) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 575) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 576) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 577) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 578) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 579) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 580) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , -0.394906131556667 ]
+ans(1:nrow, 581) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 582) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 583) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 584) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 585) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 586) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , -0.394906131556667 ]
+ans(1:nrow, 587) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 588) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 589) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , -0.394906131556667 ]
+ans(1:nrow, 590) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , +0.148368085928000 ]
+ans(1:nrow, 591) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , +0.148368085928000 ]
+ans(1:nrow, 592) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , +0.148368085928000 ]
+ans(1:nrow, 593) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 594) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 595) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 596) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , +0.148368085928000 ]
+ans(1:nrow, 597) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , +0.148368085928000 ]
+ans(1:nrow, 598) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 599) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 600) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 601) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , +0.148368085928000 ]
+ans(1:nrow, 602) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 603) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 604) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 605) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 606) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 607) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 608) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 609) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 610) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 611) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , +0.148368085928000 ]
+ans(1:nrow, 612) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , +0.148368085928000 ]
+ans(1:nrow, 613) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 614) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 615) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 616) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , +0.148368085928000 ]
+ans(1:nrow, 617) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 618) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 619) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 620) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 621) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 622) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 623) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 624) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 625) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 626) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , +0.148368085928000 ]
+ans(1:nrow, 627) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 628) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 629) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 630) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 631) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 632) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 633) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 634) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 635) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 636) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , +0.148368085928000 ]
+ans(1:nrow, 637) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 638) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 639) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 640) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 641) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 642) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , +0.148368085928000 ]
+ans(1:nrow, 643) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 644) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 645) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , +0.148368085928000 ]
+ans(1:nrow, 646) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , -0.028553147692667 ]
+ans(1:nrow, 647) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , -0.028553147692667 ]
+ans(1:nrow, 648) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , -0.028553147692667 ]
+ans(1:nrow, 649) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 650) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 651) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , -0.028553147692667 ]
+ans(1:nrow, 652) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , -0.028553147692667 ]
+ans(1:nrow, 653) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 654) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 655) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , -0.028553147692667 ]
+ans(1:nrow, 656) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 657) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 658) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 659) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 660) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 661) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , -0.028553147692667 ]
+ans(1:nrow, 662) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , -0.028553147692667 ]
+ans(1:nrow, 663) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 664) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 665) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , -0.028553147692667 ]
+ans(1:nrow, 666) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 667) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 668) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 669) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 670) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 671) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , -0.028553147692667 ]
+ans(1:nrow, 672) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 673) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 674) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 675) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 676) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 677) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , -0.028553147692667 ]
+ans(1:nrow, 678) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 679) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 680) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , -0.028553147692667 ]
+ans(1:nrow, 681) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , +0.002532258209850 ]
+ans(1:nrow, 682) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , +0.002532258209850 ]
+ans(1:nrow, 683) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , +0.002532258209850 ]
+ans(1:nrow, 684) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 685) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850 ]
+ans(1:nrow, 686) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850 ]
+ans(1:nrow, 687) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 688) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850 ]
+ans(1:nrow, 689) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 690) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 691) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , +0.002532258209850 ]
+ans(1:nrow, 692) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , +0.002532258209850 ]
+ans(1:nrow, 693) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 694) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850 ]
+ans(1:nrow, 695) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 696) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 697) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , +0.002532258209850 ]
+ans(1:nrow, 698) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 699) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 700) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , +0.002532258209850 ]
+ans(1:nrow, 701) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 702) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 703) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 704) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 705) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 706) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 707) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 708) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 709) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 710) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , -8.3414141296e-05 ]
+ans(1:nrow, 711) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , +6.6130980188e-07 ]
+ans(1:nrow, 712) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , +6.6130980188e-07 ]
+ans(1:nrow, 713) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07 ]
+ans(1:nrow, 714) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , +6.6130980188e-07 ]
+ans(1:nrow, 715) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , -4.6404125000e-10 ]
+
+END subroutine QP_Tetrahedron_Order19
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90
new file mode 100644
index 000000000..7482d5c7c
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order2.F90
@@ -0,0 +1,28 @@
+PURE SUBROUTINE QP_Tetrahedron_Order2(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ nrow = 4
+ ncol = 4
+
+ ans(1, 1) = 0.585410196624969
+ ans(2, 1) = 0.138196601125011
+ ans(3, 1) = 0.138196601125011
+ ans(4, 1) = 0.041666666666667
+
+ ans(1, 2) = 0.138196601125011
+ ans(2, 2) = 0.138196601125011
+ ans(3, 2) = 0.138196601125011
+ ans(4, 2) = 0.041666666666667
+
+ ans(1, 3) = 0.138196601125011
+ ans(2, 3) = 0.138196601125011
+ ans(3, 3) = 0.585410196624969
+ ans(4, 3) = 0.041666666666667
+
+ ans(1, 4) = 0.138196601125011
+ ans(2, 4) = 0.585410196624969
+ ans(3, 4) = 0.138196601125011
+ ans(4, 4) = 0.041666666666667
+
+END SUBROUTINE QP_Tetrahedron_Order2
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90
new file mode 100644
index 000000000..a3655aa76
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order20.F90
@@ -0,0 +1,10 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order20(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 1001)
+ nrow = 4; ncol = 1001
+
+ CALL QP_Tetrahedron_Order21(ans, nrow, ncol)
+END SUBROUTINE QP_Tetrahedron_Order20
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90
new file mode 100644
index 000000000..a513352e7
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order21.F90
@@ -0,0 +1,1010 @@
+PURE subroutine QP_Tetrahedron_Order21(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 1001)
+ nrow=4;ncol= 1001
+
+ans(1:nrow, 1) = [ 0.0416666666667, 0.0416666666667, 0.8750000000000 , +0.148296360441500 ]
+ans(1:nrow, 2) = [ 0.0416666666667, 0.1250000000000, 0.7916666666670 , +0.148296360441500 ]
+ans(1:nrow, 3) = [ 0.0416666666667, 0.2083333333330, 0.7083333333330 , +0.148296360441500 ]
+ans(1:nrow, 4) = [ 0.0416666666667, 0.2916666666670, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 5) = [ 0.0416666666667, 0.3750000000000, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 6) = [ 0.0416666666667, 0.4583333333330, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 7) = [ 0.0416666666667, 0.5416666666670, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 8) = [ 0.0416666666667, 0.6250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 9) = [ 0.0416666666667, 0.7083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 10) = [ 0.0416666666667, 0.7916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 11) = [ 0.0416666666667, 0.8750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 12) = [ 0.1250000000000, 0.0416666666667, 0.7916666666670 , +0.148296360441500 ]
+ans(1:nrow, 13) = [ 0.1250000000000, 0.1250000000000, 0.7083333333330 , +0.148296360441500 ]
+ans(1:nrow, 14) = [ 0.1250000000000, 0.2083333333330, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 15) = [ 0.1250000000000, 0.2916666666670, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 16) = [ 0.1250000000000, 0.3750000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 17) = [ 0.1250000000000, 0.4583333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 18) = [ 0.1250000000000, 0.5416666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 19) = [ 0.1250000000000, 0.6250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 20) = [ 0.1250000000000, 0.7083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 21) = [ 0.1250000000000, 0.7916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 22) = [ 0.2083333333330, 0.0416666666667, 0.7083333333330 , +0.148296360441500 ]
+ans(1:nrow, 23) = [ 0.2083333333330, 0.1250000000000, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 24) = [ 0.2083333333330, 0.2083333333330, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 25) = [ 0.2083333333330, 0.2916666666670, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 26) = [ 0.2083333333330, 0.3750000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 27) = [ 0.2083333333330, 0.4583333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 28) = [ 0.2083333333330, 0.5416666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 29) = [ 0.2083333333330, 0.6250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 30) = [ 0.2083333333330, 0.7083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 31) = [ 0.2916666666670, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 32) = [ 0.2916666666670, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 33) = [ 0.2916666666670, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 34) = [ 0.2916666666670, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 35) = [ 0.2916666666670, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 36) = [ 0.2916666666670, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 37) = [ 0.2916666666670, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 38) = [ 0.2916666666670, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 39) = [ 0.3750000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 40) = [ 0.3750000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 41) = [ 0.3750000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 42) = [ 0.3750000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 43) = [ 0.3750000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 44) = [ 0.3750000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 45) = [ 0.3750000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 46) = [ 0.4583333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 47) = [ 0.4583333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 48) = [ 0.4583333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 49) = [ 0.4583333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 50) = [ 0.4583333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 51) = [ 0.4583333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 52) = [ 0.5416666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 53) = [ 0.5416666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 54) = [ 0.5416666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 55) = [ 0.5416666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 56) = [ 0.5416666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 57) = [ 0.6250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 58) = [ 0.6250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 59) = [ 0.6250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 60) = [ 0.6250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 61) = [ 0.7083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 62) = [ 0.7083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 63) = [ 0.7083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 64) = [ 0.7916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 65) = [ 0.7916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 66) = [ 0.8750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 67) = [ 0.0416666666667, 0.0416666666667, 0.7916666666670 , +0.148296360441500 ]
+ans(1:nrow, 68) = [ 0.0416666666667, 0.1250000000000, 0.7083333333330 , +0.148296360441500 ]
+ans(1:nrow, 69) = [ 0.0416666666667, 0.2083333333330, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 70) = [ 0.0416666666667, 0.2916666666670, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 71) = [ 0.0416666666667, 0.3750000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 72) = [ 0.0416666666667, 0.4583333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 73) = [ 0.0416666666667, 0.5416666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 74) = [ 0.0416666666667, 0.6250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 75) = [ 0.0416666666667, 0.7083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 76) = [ 0.0416666666667, 0.7916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 77) = [ 0.1250000000000, 0.0416666666667, 0.7083333333330 , +0.148296360441500 ]
+ans(1:nrow, 78) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 79) = [ 0.1250000000000, 0.2083333333330, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 80) = [ 0.1250000000000, 0.2916666666670, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 81) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 82) = [ 0.1250000000000, 0.4583333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 83) = [ 0.1250000000000, 0.5416666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 84) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 85) = [ 0.1250000000000, 0.7083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 86) = [ 0.2083333333330, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 87) = [ 0.2083333333330, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 88) = [ 0.2083333333330, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 89) = [ 0.2083333333330, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 90) = [ 0.2083333333330, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 91) = [ 0.2083333333330, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 92) = [ 0.2083333333330, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 93) = [ 0.2083333333330, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 94) = [ 0.2916666666670, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 95) = [ 0.2916666666670, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 96) = [ 0.2916666666670, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 97) = [ 0.2916666666670, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 98) = [ 0.2916666666670, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 99) = [ 0.2916666666670, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 100) = [ 0.2916666666670, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 101) = [ 0.3750000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 102) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 103) = [ 0.3750000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 104) = [ 0.3750000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 105) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 106) = [ 0.3750000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 107) = [ 0.4583333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 108) = [ 0.4583333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 109) = [ 0.4583333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 110) = [ 0.4583333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 111) = [ 0.4583333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 112) = [ 0.5416666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 113) = [ 0.5416666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 114) = [ 0.5416666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 115) = [ 0.5416666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 116) = [ 0.6250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 117) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 118) = [ 0.6250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 119) = [ 0.7083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 120) = [ 0.7083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 121) = [ 0.7916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 122) = [ 0.0416666666667, 0.0416666666667, 0.7083333333330 , +0.148296360441500 ]
+ans(1:nrow, 123) = [ 0.0416666666667, 0.1250000000000, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 124) = [ 0.0416666666667, 0.2083333333330, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 125) = [ 0.0416666666667, 0.2916666666670, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 126) = [ 0.0416666666667, 0.3750000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 127) = [ 0.0416666666667, 0.4583333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 128) = [ 0.0416666666667, 0.5416666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 129) = [ 0.0416666666667, 0.6250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 130) = [ 0.0416666666667, 0.7083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 131) = [ 0.1250000000000, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 132) = [ 0.1250000000000, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 133) = [ 0.1250000000000, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 134) = [ 0.1250000000000, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 135) = [ 0.1250000000000, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 136) = [ 0.1250000000000, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 137) = [ 0.1250000000000, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 138) = [ 0.1250000000000, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 139) = [ 0.2083333333330, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 140) = [ 0.2083333333330, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 141) = [ 0.2083333333330, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 142) = [ 0.2083333333330, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 143) = [ 0.2083333333330, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 144) = [ 0.2083333333330, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 145) = [ 0.2083333333330, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 146) = [ 0.2916666666670, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 147) = [ 0.2916666666670, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 148) = [ 0.2916666666670, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 149) = [ 0.2916666666670, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 150) = [ 0.2916666666670, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 151) = [ 0.2916666666670, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 152) = [ 0.3750000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 153) = [ 0.3750000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 154) = [ 0.3750000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 155) = [ 0.3750000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 156) = [ 0.3750000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 157) = [ 0.4583333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 158) = [ 0.4583333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 159) = [ 0.4583333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 160) = [ 0.4583333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 161) = [ 0.5416666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 162) = [ 0.5416666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 163) = [ 0.5416666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 164) = [ 0.6250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 165) = [ 0.6250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 166) = [ 0.7083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 167) = [ 0.0416666666667, 0.0416666666667, 0.6250000000000 , +0.148296360441500 ]
+ans(1:nrow, 168) = [ 0.0416666666667, 0.1250000000000, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 169) = [ 0.0416666666667, 0.2083333333330, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 170) = [ 0.0416666666667, 0.2916666666670, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 171) = [ 0.0416666666667, 0.3750000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 172) = [ 0.0416666666667, 0.4583333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 173) = [ 0.0416666666667, 0.5416666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 174) = [ 0.0416666666667, 0.6250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 175) = [ 0.1250000000000, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 176) = [ 0.1250000000000, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 177) = [ 0.1250000000000, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 178) = [ 0.1250000000000, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 179) = [ 0.1250000000000, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 180) = [ 0.1250000000000, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 181) = [ 0.1250000000000, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 182) = [ 0.2083333333330, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 183) = [ 0.2083333333330, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 184) = [ 0.2083333333330, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 185) = [ 0.2083333333330, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 186) = [ 0.2083333333330, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 187) = [ 0.2083333333330, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 188) = [ 0.2916666666670, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 189) = [ 0.2916666666670, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 190) = [ 0.2916666666670, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 191) = [ 0.2916666666670, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 192) = [ 0.2916666666670, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 193) = [ 0.3750000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 194) = [ 0.3750000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 195) = [ 0.3750000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 196) = [ 0.3750000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 197) = [ 0.4583333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 198) = [ 0.4583333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 199) = [ 0.4583333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 200) = [ 0.5416666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 201) = [ 0.5416666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 202) = [ 0.6250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 203) = [ 0.0416666666667, 0.0416666666667, 0.5416666666670 , +0.148296360441500 ]
+ans(1:nrow, 204) = [ 0.0416666666667, 0.1250000000000, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 205) = [ 0.0416666666667, 0.2083333333330, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 206) = [ 0.0416666666667, 0.2916666666670, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 207) = [ 0.0416666666667, 0.3750000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 208) = [ 0.0416666666667, 0.4583333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 209) = [ 0.0416666666667, 0.5416666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 210) = [ 0.1250000000000, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 211) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 212) = [ 0.1250000000000, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 213) = [ 0.1250000000000, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 214) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 215) = [ 0.1250000000000, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 216) = [ 0.2083333333330, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 217) = [ 0.2083333333330, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 218) = [ 0.2083333333330, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 219) = [ 0.2083333333330, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 220) = [ 0.2083333333330, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 221) = [ 0.2916666666670, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 222) = [ 0.2916666666670, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 223) = [ 0.2916666666670, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 224) = [ 0.2916666666670, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 225) = [ 0.3750000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 226) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 227) = [ 0.3750000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 228) = [ 0.4583333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 229) = [ 0.4583333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 230) = [ 0.5416666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 231) = [ 0.0416666666667, 0.0416666666667, 0.4583333333330 , +0.148296360441500 ]
+ans(1:nrow, 232) = [ 0.0416666666667, 0.1250000000000, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 233) = [ 0.0416666666667, 0.2083333333330, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 234) = [ 0.0416666666667, 0.2916666666670, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 235) = [ 0.0416666666667, 0.3750000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 236) = [ 0.0416666666667, 0.4583333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 237) = [ 0.1250000000000, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 238) = [ 0.1250000000000, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 239) = [ 0.1250000000000, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 240) = [ 0.1250000000000, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 241) = [ 0.1250000000000, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 242) = [ 0.2083333333330, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 243) = [ 0.2083333333330, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 244) = [ 0.2083333333330, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 245) = [ 0.2083333333330, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 246) = [ 0.2916666666670, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 247) = [ 0.2916666666670, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 248) = [ 0.2916666666670, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 249) = [ 0.3750000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 250) = [ 0.3750000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 251) = [ 0.4583333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 252) = [ 0.0416666666667, 0.0416666666667, 0.3750000000000 , +0.148296360441500 ]
+ans(1:nrow, 253) = [ 0.0416666666667, 0.1250000000000, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 254) = [ 0.0416666666667, 0.2083333333330, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 255) = [ 0.0416666666667, 0.2916666666670, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 256) = [ 0.0416666666667, 0.3750000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 257) = [ 0.1250000000000, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 258) = [ 0.1250000000000, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 259) = [ 0.1250000000000, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 260) = [ 0.1250000000000, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 261) = [ 0.2083333333330, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 262) = [ 0.2083333333330, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 263) = [ 0.2083333333330, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 264) = [ 0.2916666666670, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 265) = [ 0.2916666666670, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 266) = [ 0.3750000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 267) = [ 0.0416666666667, 0.0416666666667, 0.2916666666670 , +0.148296360441500 ]
+ans(1:nrow, 268) = [ 0.0416666666667, 0.1250000000000, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 269) = [ 0.0416666666667, 0.2083333333330, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 270) = [ 0.0416666666667, 0.2916666666670, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 271) = [ 0.1250000000000, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 272) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 273) = [ 0.1250000000000, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 274) = [ 0.2083333333330, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 275) = [ 0.2083333333330, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 276) = [ 0.2916666666670, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 277) = [ 0.0416666666667, 0.0416666666667, 0.2083333333330 , +0.148296360441500 ]
+ans(1:nrow, 278) = [ 0.0416666666667, 0.1250000000000, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 279) = [ 0.0416666666667, 0.2083333333330, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 280) = [ 0.1250000000000, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 281) = [ 0.1250000000000, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 282) = [ 0.2083333333330, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 283) = [ 0.0416666666667, 0.0416666666667, 0.1250000000000 , +0.148296360441500 ]
+ans(1:nrow, 284) = [ 0.0416666666667, 0.1250000000000, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 285) = [ 0.1250000000000, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 286) = [ 0.0416666666667, 0.0416666666667, 0.0416666666667 , +0.148296360441500 ]
+ans(1:nrow, 287) = [ 0.0454545454545, 0.0454545454545, 0.8636363636360 , -0.572508521791667 ]
+ans(1:nrow, 288) = [ 0.0454545454545, 0.1363636363640, 0.7727272727270 , -0.572508521791667 ]
+ans(1:nrow, 289) = [ 0.0454545454545, 0.2272727272730, 0.6818181818180 , -0.572508521791667 ]
+ans(1:nrow, 290) = [ 0.0454545454545, 0.3181818181820, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 291) = [ 0.0454545454545, 0.4090909090910, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 292) = [ 0.0454545454545, 0.5000000000000, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 293) = [ 0.0454545454545, 0.5909090909090, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 294) = [ 0.0454545454545, 0.6818181818180, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 295) = [ 0.0454545454545, 0.7727272727270, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 296) = [ 0.0454545454545, 0.8636363636360, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 297) = [ 0.1363636363640, 0.0454545454545, 0.7727272727270 , -0.572508521791667 ]
+ans(1:nrow, 298) = [ 0.1363636363640, 0.1363636363640, 0.6818181818180 , -0.572508521791667 ]
+ans(1:nrow, 299) = [ 0.1363636363640, 0.2272727272730, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 300) = [ 0.1363636363640, 0.3181818181820, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 301) = [ 0.1363636363640, 0.4090909090910, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 302) = [ 0.1363636363640, 0.5000000000000, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 303) = [ 0.1363636363640, 0.5909090909090, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 304) = [ 0.1363636363640, 0.6818181818180, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 305) = [ 0.1363636363640, 0.7727272727270, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 306) = [ 0.2272727272730, 0.0454545454545, 0.6818181818180 , -0.572508521791667 ]
+ans(1:nrow, 307) = [ 0.2272727272730, 0.1363636363640, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 308) = [ 0.2272727272730, 0.2272727272730, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 309) = [ 0.2272727272730, 0.3181818181820, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 310) = [ 0.2272727272730, 0.4090909090910, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 311) = [ 0.2272727272730, 0.5000000000000, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 312) = [ 0.2272727272730, 0.5909090909090, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 313) = [ 0.2272727272730, 0.6818181818180, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 314) = [ 0.3181818181820, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 315) = [ 0.3181818181820, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 316) = [ 0.3181818181820, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 317) = [ 0.3181818181820, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 318) = [ 0.3181818181820, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 319) = [ 0.3181818181820, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 320) = [ 0.3181818181820, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 321) = [ 0.4090909090910, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 322) = [ 0.4090909090910, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 323) = [ 0.4090909090910, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 324) = [ 0.4090909090910, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 325) = [ 0.4090909090910, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 326) = [ 0.4090909090910, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 327) = [ 0.5000000000000, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 328) = [ 0.5000000000000, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 329) = [ 0.5000000000000, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 330) = [ 0.5000000000000, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 331) = [ 0.5000000000000, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 332) = [ 0.5909090909090, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 333) = [ 0.5909090909090, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 334) = [ 0.5909090909090, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 335) = [ 0.5909090909090, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 336) = [ 0.6818181818180, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 337) = [ 0.6818181818180, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 338) = [ 0.6818181818180, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 339) = [ 0.7727272727270, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 340) = [ 0.7727272727270, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 341) = [ 0.8636363636360, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 342) = [ 0.0454545454545, 0.0454545454545, 0.7727272727270 , -0.572508521791667 ]
+ans(1:nrow, 343) = [ 0.0454545454545, 0.1363636363640, 0.6818181818180 , -0.572508521791667 ]
+ans(1:nrow, 344) = [ 0.0454545454545, 0.2272727272730, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 345) = [ 0.0454545454545, 0.3181818181820, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 346) = [ 0.0454545454545, 0.4090909090910, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 347) = [ 0.0454545454545, 0.5000000000000, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 348) = [ 0.0454545454545, 0.5909090909090, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 349) = [ 0.0454545454545, 0.6818181818180, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 350) = [ 0.0454545454545, 0.7727272727270, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 351) = [ 0.1363636363640, 0.0454545454545, 0.6818181818180 , -0.572508521791667 ]
+ans(1:nrow, 352) = [ 0.1363636363640, 0.1363636363640, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 353) = [ 0.1363636363640, 0.2272727272730, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 354) = [ 0.1363636363640, 0.3181818181820, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 355) = [ 0.1363636363640, 0.4090909090910, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 356) = [ 0.1363636363640, 0.5000000000000, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 357) = [ 0.1363636363640, 0.5909090909090, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 358) = [ 0.1363636363640, 0.6818181818180, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 359) = [ 0.2272727272730, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 360) = [ 0.2272727272730, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 361) = [ 0.2272727272730, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 362) = [ 0.2272727272730, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 363) = [ 0.2272727272730, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 364) = [ 0.2272727272730, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 365) = [ 0.2272727272730, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 366) = [ 0.3181818181820, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 367) = [ 0.3181818181820, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 368) = [ 0.3181818181820, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 369) = [ 0.3181818181820, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 370) = [ 0.3181818181820, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 371) = [ 0.3181818181820, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 372) = [ 0.4090909090910, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 373) = [ 0.4090909090910, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 374) = [ 0.4090909090910, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 375) = [ 0.4090909090910, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 376) = [ 0.4090909090910, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 377) = [ 0.5000000000000, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 378) = [ 0.5000000000000, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 379) = [ 0.5000000000000, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 380) = [ 0.5000000000000, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 381) = [ 0.5909090909090, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 382) = [ 0.5909090909090, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 383) = [ 0.5909090909090, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 384) = [ 0.6818181818180, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 385) = [ 0.6818181818180, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 386) = [ 0.7727272727270, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 387) = [ 0.0454545454545, 0.0454545454545, 0.6818181818180 , -0.572508521791667 ]
+ans(1:nrow, 388) = [ 0.0454545454545, 0.1363636363640, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 389) = [ 0.0454545454545, 0.2272727272730, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 390) = [ 0.0454545454545, 0.3181818181820, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 391) = [ 0.0454545454545, 0.4090909090910, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 392) = [ 0.0454545454545, 0.5000000000000, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 393) = [ 0.0454545454545, 0.5909090909090, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 394) = [ 0.0454545454545, 0.6818181818180, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 395) = [ 0.1363636363640, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 396) = [ 0.1363636363640, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 397) = [ 0.1363636363640, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 398) = [ 0.1363636363640, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 399) = [ 0.1363636363640, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 400) = [ 0.1363636363640, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 401) = [ 0.1363636363640, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 402) = [ 0.2272727272730, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 403) = [ 0.2272727272730, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 404) = [ 0.2272727272730, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 405) = [ 0.2272727272730, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 406) = [ 0.2272727272730, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 407) = [ 0.2272727272730, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 408) = [ 0.3181818181820, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 409) = [ 0.3181818181820, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 410) = [ 0.3181818181820, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 411) = [ 0.3181818181820, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 412) = [ 0.3181818181820, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 413) = [ 0.4090909090910, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 414) = [ 0.4090909090910, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 415) = [ 0.4090909090910, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 416) = [ 0.4090909090910, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 417) = [ 0.5000000000000, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 418) = [ 0.5000000000000, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 419) = [ 0.5000000000000, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 420) = [ 0.5909090909090, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 421) = [ 0.5909090909090, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 422) = [ 0.6818181818180, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 423) = [ 0.0454545454545, 0.0454545454545, 0.5909090909090 , -0.572508521791667 ]
+ans(1:nrow, 424) = [ 0.0454545454545, 0.1363636363640, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 425) = [ 0.0454545454545, 0.2272727272730, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 426) = [ 0.0454545454545, 0.3181818181820, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 427) = [ 0.0454545454545, 0.4090909090910, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 428) = [ 0.0454545454545, 0.5000000000000, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 429) = [ 0.0454545454545, 0.5909090909090, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 430) = [ 0.1363636363640, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 431) = [ 0.1363636363640, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 432) = [ 0.1363636363640, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 433) = [ 0.1363636363640, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 434) = [ 0.1363636363640, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 435) = [ 0.1363636363640, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 436) = [ 0.2272727272730, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 437) = [ 0.2272727272730, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 438) = [ 0.2272727272730, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 439) = [ 0.2272727272730, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 440) = [ 0.2272727272730, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 441) = [ 0.3181818181820, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 442) = [ 0.3181818181820, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 443) = [ 0.3181818181820, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 444) = [ 0.3181818181820, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 445) = [ 0.4090909090910, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 446) = [ 0.4090909090910, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 447) = [ 0.4090909090910, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 448) = [ 0.5000000000000, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 449) = [ 0.5000000000000, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 450) = [ 0.5909090909090, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 451) = [ 0.0454545454545, 0.0454545454545, 0.5000000000000 , -0.572508521791667 ]
+ans(1:nrow, 452) = [ 0.0454545454545, 0.1363636363640, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 453) = [ 0.0454545454545, 0.2272727272730, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 454) = [ 0.0454545454545, 0.3181818181820, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 455) = [ 0.0454545454545, 0.4090909090910, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 456) = [ 0.0454545454545, 0.5000000000000, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 457) = [ 0.1363636363640, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 458) = [ 0.1363636363640, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 459) = [ 0.1363636363640, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 460) = [ 0.1363636363640, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 461) = [ 0.1363636363640, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 462) = [ 0.2272727272730, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 463) = [ 0.2272727272730, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 464) = [ 0.2272727272730, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 465) = [ 0.2272727272730, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 466) = [ 0.3181818181820, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 467) = [ 0.3181818181820, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 468) = [ 0.3181818181820, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 469) = [ 0.4090909090910, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 470) = [ 0.4090909090910, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 471) = [ 0.5000000000000, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 472) = [ 0.0454545454545, 0.0454545454545, 0.4090909090910 , -0.572508521791667 ]
+ans(1:nrow, 473) = [ 0.0454545454545, 0.1363636363640, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 474) = [ 0.0454545454545, 0.2272727272730, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 475) = [ 0.0454545454545, 0.3181818181820, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 476) = [ 0.0454545454545, 0.4090909090910, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 477) = [ 0.1363636363640, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 478) = [ 0.1363636363640, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 479) = [ 0.1363636363640, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 480) = [ 0.1363636363640, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 481) = [ 0.2272727272730, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 482) = [ 0.2272727272730, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 483) = [ 0.2272727272730, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 484) = [ 0.3181818181820, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 485) = [ 0.3181818181820, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 486) = [ 0.4090909090910, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 487) = [ 0.0454545454545, 0.0454545454545, 0.3181818181820 , -0.572508521791667 ]
+ans(1:nrow, 488) = [ 0.0454545454545, 0.1363636363640, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 489) = [ 0.0454545454545, 0.2272727272730, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 490) = [ 0.0454545454545, 0.3181818181820, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 491) = [ 0.1363636363640, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 492) = [ 0.1363636363640, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 493) = [ 0.1363636363640, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 494) = [ 0.2272727272730, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 495) = [ 0.2272727272730, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 496) = [ 0.3181818181820, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 497) = [ 0.0454545454545, 0.0454545454545, 0.2272727272730 , -0.572508521791667 ]
+ans(1:nrow, 498) = [ 0.0454545454545, 0.1363636363640, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 499) = [ 0.0454545454545, 0.2272727272730, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 500) = [ 0.1363636363640, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 501) = [ 0.1363636363640, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 502) = [ 0.2272727272730, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 503) = [ 0.0454545454545, 0.0454545454545, 0.1363636363640 , -0.572508521791667 ]
+ans(1:nrow, 504) = [ 0.0454545454545, 0.1363636363640, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 505) = [ 0.1363636363640, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 506) = [ 0.0454545454545, 0.0454545454545, 0.0454545454545 , -0.572508521791667 ]
+ans(1:nrow, 507) = [ 0.0500000000000, 0.0500000000000, 0.8500000000000 , +0.889679139245000 ]
+ans(1:nrow, 508) = [ 0.0500000000000, 0.1500000000000, 0.7500000000000 , +0.889679139245000 ]
+ans(1:nrow, 509) = [ 0.0500000000000, 0.2500000000000, 0.6500000000000 , +0.889679139245000 ]
+ans(1:nrow, 510) = [ 0.0500000000000, 0.3500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 511) = [ 0.0500000000000, 0.4500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 512) = [ 0.0500000000000, 0.5500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 513) = [ 0.0500000000000, 0.6500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 514) = [ 0.0500000000000, 0.7500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 515) = [ 0.0500000000000, 0.8500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 516) = [ 0.1500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000 ]
+ans(1:nrow, 517) = [ 0.1500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000 ]
+ans(1:nrow, 518) = [ 0.1500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 519) = [ 0.1500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 520) = [ 0.1500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 521) = [ 0.1500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 522) = [ 0.1500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 523) = [ 0.1500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 524) = [ 0.2500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000 ]
+ans(1:nrow, 525) = [ 0.2500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 526) = [ 0.2500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 527) = [ 0.2500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 528) = [ 0.2500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 529) = [ 0.2500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 530) = [ 0.2500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 531) = [ 0.3500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 532) = [ 0.3500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 533) = [ 0.3500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 534) = [ 0.3500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 535) = [ 0.3500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 536) = [ 0.3500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 537) = [ 0.4500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 538) = [ 0.4500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 539) = [ 0.4500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 540) = [ 0.4500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 541) = [ 0.4500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 542) = [ 0.5500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 543) = [ 0.5500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 544) = [ 0.5500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 545) = [ 0.5500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 546) = [ 0.6500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 547) = [ 0.6500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 548) = [ 0.6500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 549) = [ 0.7500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 550) = [ 0.7500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 551) = [ 0.8500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 552) = [ 0.0500000000000, 0.0500000000000, 0.7500000000000 , +0.889679139245000 ]
+ans(1:nrow, 553) = [ 0.0500000000000, 0.1500000000000, 0.6500000000000 , +0.889679139245000 ]
+ans(1:nrow, 554) = [ 0.0500000000000, 0.2500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 555) = [ 0.0500000000000, 0.3500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 556) = [ 0.0500000000000, 0.4500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 557) = [ 0.0500000000000, 0.5500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 558) = [ 0.0500000000000, 0.6500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 559) = [ 0.0500000000000, 0.7500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 560) = [ 0.1500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000 ]
+ans(1:nrow, 561) = [ 0.1500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 562) = [ 0.1500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 563) = [ 0.1500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 564) = [ 0.1500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 565) = [ 0.1500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 566) = [ 0.1500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 567) = [ 0.2500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 568) = [ 0.2500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 569) = [ 0.2500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 570) = [ 0.2500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 571) = [ 0.2500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 572) = [ 0.2500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 573) = [ 0.3500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 574) = [ 0.3500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 575) = [ 0.3500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 576) = [ 0.3500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 577) = [ 0.3500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 578) = [ 0.4500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 579) = [ 0.4500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 580) = [ 0.4500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 581) = [ 0.4500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 582) = [ 0.5500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 583) = [ 0.5500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 584) = [ 0.5500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 585) = [ 0.6500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 586) = [ 0.6500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 587) = [ 0.7500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 588) = [ 0.0500000000000, 0.0500000000000, 0.6500000000000 , +0.889679139245000 ]
+ans(1:nrow, 589) = [ 0.0500000000000, 0.1500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 590) = [ 0.0500000000000, 0.2500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 591) = [ 0.0500000000000, 0.3500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 592) = [ 0.0500000000000, 0.4500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 593) = [ 0.0500000000000, 0.5500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 594) = [ 0.0500000000000, 0.6500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 595) = [ 0.1500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 596) = [ 0.1500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 597) = [ 0.1500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 598) = [ 0.1500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 599) = [ 0.1500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 600) = [ 0.1500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 601) = [ 0.2500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 602) = [ 0.2500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 603) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 604) = [ 0.2500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 605) = [ 0.2500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 606) = [ 0.3500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 607) = [ 0.3500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 608) = [ 0.3500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 609) = [ 0.3500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 610) = [ 0.4500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 611) = [ 0.4500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 612) = [ 0.4500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 613) = [ 0.5500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 614) = [ 0.5500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 615) = [ 0.6500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 616) = [ 0.0500000000000, 0.0500000000000, 0.5500000000000 , +0.889679139245000 ]
+ans(1:nrow, 617) = [ 0.0500000000000, 0.1500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 618) = [ 0.0500000000000, 0.2500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 619) = [ 0.0500000000000, 0.3500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 620) = [ 0.0500000000000, 0.4500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 621) = [ 0.0500000000000, 0.5500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 622) = [ 0.1500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 623) = [ 0.1500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 624) = [ 0.1500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 625) = [ 0.1500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 626) = [ 0.1500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 627) = [ 0.2500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 628) = [ 0.2500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 629) = [ 0.2500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 630) = [ 0.2500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 631) = [ 0.3500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 632) = [ 0.3500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 633) = [ 0.3500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 634) = [ 0.4500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 635) = [ 0.4500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 636) = [ 0.5500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 637) = [ 0.0500000000000, 0.0500000000000, 0.4500000000000 , +0.889679139245000 ]
+ans(1:nrow, 638) = [ 0.0500000000000, 0.1500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 639) = [ 0.0500000000000, 0.2500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 640) = [ 0.0500000000000, 0.3500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 641) = [ 0.0500000000000, 0.4500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 642) = [ 0.1500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 643) = [ 0.1500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 644) = [ 0.1500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 645) = [ 0.1500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 646) = [ 0.2500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 647) = [ 0.2500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 648) = [ 0.2500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 649) = [ 0.3500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 650) = [ 0.3500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 651) = [ 0.4500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 652) = [ 0.0500000000000, 0.0500000000000, 0.3500000000000 , +0.889679139245000 ]
+ans(1:nrow, 653) = [ 0.0500000000000, 0.1500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 654) = [ 0.0500000000000, 0.2500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 655) = [ 0.0500000000000, 0.3500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 656) = [ 0.1500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 657) = [ 0.1500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 658) = [ 0.1500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 659) = [ 0.2500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 660) = [ 0.2500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 661) = [ 0.3500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 662) = [ 0.0500000000000, 0.0500000000000, 0.2500000000000 , +0.889679139245000 ]
+ans(1:nrow, 663) = [ 0.0500000000000, 0.1500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 664) = [ 0.0500000000000, 0.2500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 665) = [ 0.1500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 666) = [ 0.1500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 667) = [ 0.2500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 668) = [ 0.0500000000000, 0.0500000000000, 0.1500000000000 , +0.889679139245000 ]
+ans(1:nrow, 669) = [ 0.0500000000000, 0.1500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 670) = [ 0.1500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 671) = [ 0.0500000000000, 0.0500000000000, 0.0500000000000 , +0.889679139245000 ]
+ans(1:nrow, 672) = [ 0.0555555555556, 0.0555555555556, 0.8333333333330 , -0.713883808495000 ]
+ans(1:nrow, 673) = [ 0.0555555555556, 0.1666666666670, 0.7222222222220 , -0.713883808495000 ]
+ans(1:nrow, 674) = [ 0.0555555555556, 0.2777777777780, 0.6111111111110 , -0.713883808495000 ]
+ans(1:nrow, 675) = [ 0.0555555555556, 0.3888888888890, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 676) = [ 0.0555555555556, 0.5000000000000, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 677) = [ 0.0555555555556, 0.6111111111110, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 678) = [ 0.0555555555556, 0.7222222222220, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 679) = [ 0.0555555555556, 0.8333333333330, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 680) = [ 0.1666666666670, 0.0555555555556, 0.7222222222220 , -0.713883808495000 ]
+ans(1:nrow, 681) = [ 0.1666666666670, 0.1666666666670, 0.6111111111110 , -0.713883808495000 ]
+ans(1:nrow, 682) = [ 0.1666666666670, 0.2777777777780, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 683) = [ 0.1666666666670, 0.3888888888890, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 684) = [ 0.1666666666670, 0.5000000000000, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 685) = [ 0.1666666666670, 0.6111111111110, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 686) = [ 0.1666666666670, 0.7222222222220, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 687) = [ 0.2777777777780, 0.0555555555556, 0.6111111111110 , -0.713883808495000 ]
+ans(1:nrow, 688) = [ 0.2777777777780, 0.1666666666670, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 689) = [ 0.2777777777780, 0.2777777777780, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 690) = [ 0.2777777777780, 0.3888888888890, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 691) = [ 0.2777777777780, 0.5000000000000, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 692) = [ 0.2777777777780, 0.6111111111110, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 693) = [ 0.3888888888890, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 694) = [ 0.3888888888890, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 695) = [ 0.3888888888890, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 696) = [ 0.3888888888890, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 697) = [ 0.3888888888890, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 698) = [ 0.5000000000000, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 699) = [ 0.5000000000000, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 700) = [ 0.5000000000000, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 701) = [ 0.5000000000000, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 702) = [ 0.6111111111110, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 703) = [ 0.6111111111110, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 704) = [ 0.6111111111110, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 705) = [ 0.7222222222220, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 706) = [ 0.7222222222220, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 707) = [ 0.8333333333330, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 708) = [ 0.0555555555556, 0.0555555555556, 0.7222222222220 , -0.713883808495000 ]
+ans(1:nrow, 709) = [ 0.0555555555556, 0.1666666666670, 0.6111111111110 , -0.713883808495000 ]
+ans(1:nrow, 710) = [ 0.0555555555556, 0.2777777777780, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 711) = [ 0.0555555555556, 0.3888888888890, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 712) = [ 0.0555555555556, 0.5000000000000, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 713) = [ 0.0555555555556, 0.6111111111110, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 714) = [ 0.0555555555556, 0.7222222222220, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 715) = [ 0.1666666666670, 0.0555555555556, 0.6111111111110 , -0.713883808495000 ]
+ans(1:nrow, 716) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 717) = [ 0.1666666666670, 0.2777777777780, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 718) = [ 0.1666666666670, 0.3888888888890, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 719) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 720) = [ 0.1666666666670, 0.6111111111110, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 721) = [ 0.2777777777780, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 722) = [ 0.2777777777780, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 723) = [ 0.2777777777780, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 724) = [ 0.2777777777780, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 725) = [ 0.2777777777780, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 726) = [ 0.3888888888890, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 727) = [ 0.3888888888890, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 728) = [ 0.3888888888890, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 729) = [ 0.3888888888890, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 730) = [ 0.5000000000000, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 731) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 732) = [ 0.5000000000000, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 733) = [ 0.6111111111110, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 734) = [ 0.6111111111110, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 735) = [ 0.7222222222220, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 736) = [ 0.0555555555556, 0.0555555555556, 0.6111111111110 , -0.713883808495000 ]
+ans(1:nrow, 737) = [ 0.0555555555556, 0.1666666666670, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 738) = [ 0.0555555555556, 0.2777777777780, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 739) = [ 0.0555555555556, 0.3888888888890, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 740) = [ 0.0555555555556, 0.5000000000000, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 741) = [ 0.0555555555556, 0.6111111111110, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 742) = [ 0.1666666666670, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 743) = [ 0.1666666666670, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 744) = [ 0.1666666666670, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 745) = [ 0.1666666666670, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 746) = [ 0.1666666666670, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 747) = [ 0.2777777777780, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 748) = [ 0.2777777777780, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 749) = [ 0.2777777777780, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 750) = [ 0.2777777777780, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 751) = [ 0.3888888888890, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 752) = [ 0.3888888888890, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 753) = [ 0.3888888888890, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 754) = [ 0.5000000000000, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 755) = [ 0.5000000000000, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 756) = [ 0.6111111111110, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 757) = [ 0.0555555555556, 0.0555555555556, 0.5000000000000 , -0.713883808495000 ]
+ans(1:nrow, 758) = [ 0.0555555555556, 0.1666666666670, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 759) = [ 0.0555555555556, 0.2777777777780, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 760) = [ 0.0555555555556, 0.3888888888890, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 761) = [ 0.0555555555556, 0.5000000000000, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 762) = [ 0.1666666666670, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 763) = [ 0.1666666666670, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 764) = [ 0.1666666666670, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 765) = [ 0.1666666666670, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 766) = [ 0.2777777777780, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 767) = [ 0.2777777777780, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 768) = [ 0.2777777777780, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 769) = [ 0.3888888888890, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 770) = [ 0.3888888888890, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 771) = [ 0.5000000000000, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 772) = [ 0.0555555555556, 0.0555555555556, 0.3888888888890 , -0.713883808495000 ]
+ans(1:nrow, 773) = [ 0.0555555555556, 0.1666666666670, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 774) = [ 0.0555555555556, 0.2777777777780, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 775) = [ 0.0555555555556, 0.3888888888890, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 776) = [ 0.1666666666670, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 777) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 778) = [ 0.1666666666670, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 779) = [ 0.2777777777780, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 780) = [ 0.2777777777780, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 781) = [ 0.3888888888890, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 782) = [ 0.0555555555556, 0.0555555555556, 0.2777777777780 , -0.713883808495000 ]
+ans(1:nrow, 783) = [ 0.0555555555556, 0.1666666666670, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 784) = [ 0.0555555555556, 0.2777777777780, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 785) = [ 0.1666666666670, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 786) = [ 0.1666666666670, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 787) = [ 0.2777777777780, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 788) = [ 0.0555555555556, 0.0555555555556, 0.1666666666670 , -0.713883808495000 ]
+ans(1:nrow, 789) = [ 0.0555555555556, 0.1666666666670, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 790) = [ 0.1666666666670, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 791) = [ 0.0555555555556, 0.0555555555556, 0.0555555555556 , -0.713883808495000 ]
+ans(1:nrow, 792) = [ 0.0625000000000, 0.0625000000000, 0.8125000000000 , +0.315924905245000 ]
+ans(1:nrow, 793) = [ 0.0625000000000, 0.1875000000000, 0.6875000000000 , +0.315924905245000 ]
+ans(1:nrow, 794) = [ 0.0625000000000, 0.3125000000000, 0.5625000000000 , +0.315924905245000 ]
+ans(1:nrow, 795) = [ 0.0625000000000, 0.4375000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 796) = [ 0.0625000000000, 0.5625000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 797) = [ 0.0625000000000, 0.6875000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 798) = [ 0.0625000000000, 0.8125000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 799) = [ 0.1875000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000 ]
+ans(1:nrow, 800) = [ 0.1875000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000 ]
+ans(1:nrow, 801) = [ 0.1875000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 802) = [ 0.1875000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 803) = [ 0.1875000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 804) = [ 0.1875000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 805) = [ 0.3125000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000 ]
+ans(1:nrow, 806) = [ 0.3125000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 807) = [ 0.3125000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 808) = [ 0.3125000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 809) = [ 0.3125000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 810) = [ 0.4375000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 811) = [ 0.4375000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 812) = [ 0.4375000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 813) = [ 0.4375000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 814) = [ 0.5625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 815) = [ 0.5625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 816) = [ 0.5625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 817) = [ 0.6875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 818) = [ 0.6875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 819) = [ 0.8125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 820) = [ 0.0625000000000, 0.0625000000000, 0.6875000000000 , +0.315924905245000 ]
+ans(1:nrow, 821) = [ 0.0625000000000, 0.1875000000000, 0.5625000000000 , +0.315924905245000 ]
+ans(1:nrow, 822) = [ 0.0625000000000, 0.3125000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 823) = [ 0.0625000000000, 0.4375000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 824) = [ 0.0625000000000, 0.5625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 825) = [ 0.0625000000000, 0.6875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 826) = [ 0.1875000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000 ]
+ans(1:nrow, 827) = [ 0.1875000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 828) = [ 0.1875000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 829) = [ 0.1875000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 830) = [ 0.1875000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 831) = [ 0.3125000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 832) = [ 0.3125000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 833) = [ 0.3125000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 834) = [ 0.3125000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 835) = [ 0.4375000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 836) = [ 0.4375000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 837) = [ 0.4375000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 838) = [ 0.5625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 839) = [ 0.5625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 840) = [ 0.6875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 841) = [ 0.0625000000000, 0.0625000000000, 0.5625000000000 , +0.315924905245000 ]
+ans(1:nrow, 842) = [ 0.0625000000000, 0.1875000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 843) = [ 0.0625000000000, 0.3125000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 844) = [ 0.0625000000000, 0.4375000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 845) = [ 0.0625000000000, 0.5625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 846) = [ 0.1875000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 847) = [ 0.1875000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 848) = [ 0.1875000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 849) = [ 0.1875000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 850) = [ 0.3125000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 851) = [ 0.3125000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 852) = [ 0.3125000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 853) = [ 0.4375000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 854) = [ 0.4375000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 855) = [ 0.5625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 856) = [ 0.0625000000000, 0.0625000000000, 0.4375000000000 , +0.315924905245000 ]
+ans(1:nrow, 857) = [ 0.0625000000000, 0.1875000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 858) = [ 0.0625000000000, 0.3125000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 859) = [ 0.0625000000000, 0.4375000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 860) = [ 0.1875000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 861) = [ 0.1875000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 862) = [ 0.1875000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 863) = [ 0.3125000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 864) = [ 0.3125000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 865) = [ 0.4375000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 866) = [ 0.0625000000000, 0.0625000000000, 0.3125000000000 , +0.315924905245000 ]
+ans(1:nrow, 867) = [ 0.0625000000000, 0.1875000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 868) = [ 0.0625000000000, 0.3125000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 869) = [ 0.1875000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 870) = [ 0.1875000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 871) = [ 0.3125000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 872) = [ 0.0625000000000, 0.0625000000000, 0.1875000000000 , +0.315924905245000 ]
+ans(1:nrow, 873) = [ 0.0625000000000, 0.1875000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 874) = [ 0.1875000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 875) = [ 0.0625000000000, 0.0625000000000, 0.0625000000000 , +0.315924905245000 ]
+ans(1:nrow, 876) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140 , -0.076526696952333 ]
+ans(1:nrow, 877) = [ 0.0714285714286, 0.2142857142860, 0.6428571428570 , -0.076526696952333 ]
+ans(1:nrow, 878) = [ 0.0714285714286, 0.3571428571430, 0.5000000000000 , -0.076526696952333 ]
+ans(1:nrow, 879) = [ 0.0714285714286, 0.5000000000000, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 880) = [ 0.0714285714286, 0.6428571428570, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 881) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 882) = [ 0.2142857142860, 0.0714285714286, 0.6428571428570 , -0.076526696952333 ]
+ans(1:nrow, 883) = [ 0.2142857142860, 0.2142857142860, 0.5000000000000 , -0.076526696952333 ]
+ans(1:nrow, 884) = [ 0.2142857142860, 0.3571428571430, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 885) = [ 0.2142857142860, 0.5000000000000, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 886) = [ 0.2142857142860, 0.6428571428570, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 887) = [ 0.3571428571430, 0.0714285714286, 0.5000000000000 , -0.076526696952333 ]
+ans(1:nrow, 888) = [ 0.3571428571430, 0.2142857142860, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 889) = [ 0.3571428571430, 0.3571428571430, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 890) = [ 0.3571428571430, 0.5000000000000, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 891) = [ 0.5000000000000, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 892) = [ 0.5000000000000, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 893) = [ 0.5000000000000, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 894) = [ 0.6428571428570, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 895) = [ 0.6428571428570, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 896) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 897) = [ 0.0714285714286, 0.0714285714286, 0.6428571428570 , -0.076526696952333 ]
+ans(1:nrow, 898) = [ 0.0714285714286, 0.2142857142860, 0.5000000000000 , -0.076526696952333 ]
+ans(1:nrow, 899) = [ 0.0714285714286, 0.3571428571430, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 900) = [ 0.0714285714286, 0.5000000000000, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 901) = [ 0.0714285714286, 0.6428571428570, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 902) = [ 0.2142857142860, 0.0714285714286, 0.5000000000000 , -0.076526696952333 ]
+ans(1:nrow, 903) = [ 0.2142857142860, 0.2142857142860, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 904) = [ 0.2142857142860, 0.3571428571430, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 905) = [ 0.2142857142860, 0.5000000000000, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 906) = [ 0.3571428571430, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 907) = [ 0.3571428571430, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 908) = [ 0.3571428571430, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 909) = [ 0.5000000000000, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 910) = [ 0.5000000000000, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 911) = [ 0.6428571428570, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 912) = [ 0.0714285714286, 0.0714285714286, 0.5000000000000 , -0.076526696952333 ]
+ans(1:nrow, 913) = [ 0.0714285714286, 0.2142857142860, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 914) = [ 0.0714285714286, 0.3571428571430, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 915) = [ 0.0714285714286, 0.5000000000000, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 916) = [ 0.2142857142860, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 917) = [ 0.2142857142860, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 918) = [ 0.2142857142860, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 919) = [ 0.3571428571430, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 920) = [ 0.3571428571430, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 921) = [ 0.5000000000000, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 922) = [ 0.0714285714286, 0.0714285714286, 0.3571428571430 , -0.076526696952333 ]
+ans(1:nrow, 923) = [ 0.0714285714286, 0.2142857142860, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 924) = [ 0.0714285714286, 0.3571428571430, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 925) = [ 0.2142857142860, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 926) = [ 0.2142857142860, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 927) = [ 0.3571428571430, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 928) = [ 0.0714285714286, 0.0714285714286, 0.2142857142860 , -0.076526696952333 ]
+ans(1:nrow, 929) = [ 0.0714285714286, 0.2142857142860, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 930) = [ 0.2142857142860, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 931) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286 , -0.076526696952333 ]
+ans(1:nrow, 932) = [ 0.0833333333333, 0.0833333333333, 0.7500000000000 , +0.009517715897550 ]
+ans(1:nrow, 933) = [ 0.0833333333333, 0.2500000000000, 0.5833333333330 , +0.009517715897550 ]
+ans(1:nrow, 934) = [ 0.0833333333333, 0.4166666666670, 0.4166666666670 , +0.009517715897550 ]
+ans(1:nrow, 935) = [ 0.0833333333333, 0.5833333333330, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 936) = [ 0.0833333333333, 0.7500000000000, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 937) = [ 0.2500000000000, 0.0833333333333, 0.5833333333330 , +0.009517715897550 ]
+ans(1:nrow, 938) = [ 0.2500000000000, 0.2500000000000, 0.4166666666670 , +0.009517715897550 ]
+ans(1:nrow, 939) = [ 0.2500000000000, 0.4166666666670, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 940) = [ 0.2500000000000, 0.5833333333330, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 941) = [ 0.4166666666670, 0.0833333333333, 0.4166666666670 , +0.009517715897550 ]
+ans(1:nrow, 942) = [ 0.4166666666670, 0.2500000000000, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 943) = [ 0.4166666666670, 0.4166666666670, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 944) = [ 0.5833333333330, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 945) = [ 0.5833333333330, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 946) = [ 0.7500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 947) = [ 0.0833333333333, 0.0833333333333, 0.5833333333330 , +0.009517715897550 ]
+ans(1:nrow, 948) = [ 0.0833333333333, 0.2500000000000, 0.4166666666670 , +0.009517715897550 ]
+ans(1:nrow, 949) = [ 0.0833333333333, 0.4166666666670, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 950) = [ 0.0833333333333, 0.5833333333330, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 951) = [ 0.2500000000000, 0.0833333333333, 0.4166666666670 , +0.009517715897550 ]
+ans(1:nrow, 952) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 953) = [ 0.2500000000000, 0.4166666666670, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 954) = [ 0.4166666666670, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 955) = [ 0.4166666666670, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 956) = [ 0.5833333333330, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 957) = [ 0.0833333333333, 0.0833333333333, 0.4166666666670 , +0.009517715897550 ]
+ans(1:nrow, 958) = [ 0.0833333333333, 0.2500000000000, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 959) = [ 0.0833333333333, 0.4166666666670, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 960) = [ 0.2500000000000, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 961) = [ 0.2500000000000, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 962) = [ 0.4166666666670, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 963) = [ 0.0833333333333, 0.0833333333333, 0.2500000000000 , +0.009517715897550 ]
+ans(1:nrow, 964) = [ 0.0833333333333, 0.2500000000000, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 965) = [ 0.2500000000000, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 966) = [ 0.0833333333333, 0.0833333333333, 0.0833333333333 , +0.009517715897550 ]
+ans(1:nrow, 967) = [ 0.1000000000000, 0.1000000000000, 0.7000000000000 , -0.000531987018878 ]
+ans(1:nrow, 968) = [ 0.1000000000000, 0.3000000000000, 0.5000000000000 , -0.000531987018878 ]
+ans(1:nrow, 969) = [ 0.1000000000000, 0.5000000000000, 0.3000000000000 , -0.000531987018878 ]
+ans(1:nrow, 970) = [ 0.1000000000000, 0.7000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 971) = [ 0.3000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878 ]
+ans(1:nrow, 972) = [ 0.3000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878 ]
+ans(1:nrow, 973) = [ 0.3000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 974) = [ 0.5000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878 ]
+ans(1:nrow, 975) = [ 0.5000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 976) = [ 0.7000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 977) = [ 0.1000000000000, 0.1000000000000, 0.5000000000000 , -0.000531987018878 ]
+ans(1:nrow, 978) = [ 0.1000000000000, 0.3000000000000, 0.3000000000000 , -0.000531987018878 ]
+ans(1:nrow, 979) = [ 0.1000000000000, 0.5000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 980) = [ 0.3000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878 ]
+ans(1:nrow, 981) = [ 0.3000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 982) = [ 0.5000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 983) = [ 0.1000000000000, 0.1000000000000, 0.3000000000000 , -0.000531987018878 ]
+ans(1:nrow, 984) = [ 0.1000000000000, 0.3000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 985) = [ 0.3000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 986) = [ 0.1000000000000, 0.1000000000000, 0.1000000000000 , -0.000531987018878 ]
+ans(1:nrow, 987) = [ 0.1250000000000, 0.1250000000000, 0.6250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 988) = [ 0.1250000000000, 0.3750000000000, 0.3750000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 989) = [ 0.1250000000000, 0.6250000000000, 0.1250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 990) = [ 0.3750000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 991) = [ 0.3750000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 992) = [ 0.6250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 993) = [ 0.1250000000000, 0.1250000000000, 0.3750000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 994) = [ 0.1250000000000, 0.3750000000000, 0.1250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 995) = [ 0.3750000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 996) = [ 0.1250000000000, 0.1250000000000, 0.1250000000000 , +1.0426767662e-05 ]
+ans(1:nrow, 997) = [ 0.1666666666670, 0.1666666666670, 0.5000000000000 , -4.4087320125e-08 ]
+ans(1:nrow, 998) = [ 0.1666666666670, 0.5000000000000, 0.1666666666670 , -4.4087320125e-08 ]
+ans(1:nrow, 999) = [ 0.5000000000000, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08 ]
+ans(1:nrow, 1000) = [ 0.1666666666670, 0.1666666666670, 0.1666666666670 , -4.4087320125e-08 ]
+ans(1:nrow, 1001) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000 , +1.3258375e-11 ]
+
+END subroutine QP_Tetrahedron_Order21
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90
new file mode 100644
index 000000000..c6da40c22
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order3.F90
@@ -0,0 +1,25 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order3(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ ! ans(4, 5)
+
+ nrow = 4; ncol = 5
+
+ ans(1, 1) = 0.250000000000000
+ ans(2, 1) = 0.250000000000000
+ ans(3, 1) = 0.250000000000000
+ ans(4, 1) = -0.133333333333333
+
+ ans(1, 2) = 0.500000000000000
+ ans(2, 2) = 0.166666666666667
+ ans(3, 2) = 0.166666666666667
+ ans(4, 2) = 0.075000000000000
+
+ ans(1:nrow, 3) = [0.166666666666667, 0.166666666666667, 0.166666666666667, 0.075000000000000 ]
+
+ ans(1:nrow, 4) = [0.166666666666667, 0.166666666666667, 0.500000000000000, 0.075000000000000 ]
+
+ ans(1:nrow, 5) = [0.166666666666667, 0.500000000000000, 0.166666666666667, 0.075000000000000 ]
+
+END SUBROUTINE QP_Tetrahedron_Order3
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90
new file mode 100644
index 000000000..5b1a8632b
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order4.F90
@@ -0,0 +1,21 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order4(ans, nrow, ncol)
+ REAL(DFP), INTENT(inout) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 11)
+ nrow = 4; ncol = 11
+
+ans(1:nrow, 1) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.0131555555555 ]
+ans(1:nrow, 2) = [ 0.0714285714286, 0.0714285714286, 0.0714285714286, +0.0076222222222 ]
+ans(1:nrow, 3) = [ 0.0714285714286, 0.0714285714286, 0.7857142857140, +0.0076222222222 ]
+ans(1:nrow, 4) = [ 0.0714285714286, 0.7857142857140, 0.0714285714286, +0.0076222222222 ]
+ans(1:nrow, 5) = [ 0.7857142857140, 0.0714285714286, 0.0714285714286, +0.0076222222222 ]
+ans(1:nrow, 6) = [ 0.3994035761670, 0.3994035761670, 0.1005964238330, +0.0248888888888 ]
+ans(1:nrow, 7) = [ 0.3994035761670, 0.1005964238330, 0.3994035761670, +0.0248888888888 ]
+ans(1:nrow, 8) = [ 0.1005964238330, 0.3994035761670, 0.3994035761670, +0.0248888888888 ]
+ans(1:nrow, 9) = [ 0.3994035761670, 0.1005964238330, 0.1005964238330, +0.0248888888888 ]
+ans(1:nrow, 10) = [ 0.1005964238330, 0.3994035761670, 0.1005964238330, +0.0248888888888 ]
+ans(1:nrow, 11) = [ 0.1005964238330, 0.1005964238330, 0.3994035761670, +0.0248888888888 ]
+
+END SUBROUTINE QP_Tetrahedron_Order4
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90
new file mode 100644
index 000000000..09336ae93
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order5.F90
@@ -0,0 +1,23 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order5(ans, nrow, ncol)
+ REAL(DFP), INTENT(inout) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ nrow = 4; ncol = 14
+
+ans(1:nrow, 1) = [ 0.0927352503109, 0.0927352503109, 0.0927352503109, 0.01224884051940 ]
+ans(1:nrow, 2) = [ 0.7217942490670, 0.0927352503109, 0.0927352503109, 0.01224884051940 ]
+ans(1:nrow, 3) = [ 0.0927352503109, 0.7217942490670, 0.0927352503109, 0.01224884051940 ]
+ans(1:nrow, 4) = [ 0.0927352503109, 0.0927352503109, 0.7217942490670, 0.01224884051940 ]
+ans(1:nrow, 5) = [ 0.3108859192630, 0.3108859192630, 0.3108859192630, 0.01878132095300 ]
+ans(1:nrow, 6) = [ 0.0673422422101, 0.3108859192630, 0.3108859192630, 0.01878132095300 ]
+ans(1:nrow, 7) = [ 0.3108859192630, 0.0673422422101, 0.3108859192630, 0.01878132095300 ]
+ans(1:nrow, 8) = [ 0.3108859192630, 0.3108859192630, 0.0673422422101, 0.01878132095300 ]
+ans(1:nrow, 9) = [ 0.4544962958740, 0.4544962958740, 0.0455037041256, 0.00709100346285 ]
+ans(1:nrow, 10) = [ 0.4544962958740, 0.0455037041256, 0.4544962958740, 0.00709100346285 ]
+ans(1:nrow, 11) = [ 0.0455037041256, 0.4544962958740, 0.4544962958740, 0.00709100346285 ]
+ans(1:nrow, 12) = [ 0.4544962958740, 0.0455037041256, 0.0455037041256, 0.00709100346285 ]
+ans(1:nrow, 13) = [ 0.0455037041256, 0.4544962958740, 0.0455037041256, 0.00709100346285 ]
+ans(1:nrow, 14) = [ 0.0455037041256, 0.0455037041256, 0.4544962958740, 0.0709100346285 ]
+
+END SUBROUTINE QP_Tetrahedron_Order5
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90
new file mode 100644
index 000000000..decef7a90
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order6.F90
@@ -0,0 +1,34 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order6(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 24)
+ nrow = 4; ncol = 24
+
+ans(1:nrow, 1) = [ 0.2146028712590, 0.2146028712590, 0.2146028712590, 0.006653791709700 ]
+ans(1:nrow, 2) = [ 0.3561913862230, 0.2146028712590, 0.2146028712590, 0.006653791709700 ]
+ans(1:nrow, 3) = [ 0.2146028712590, 0.3561913862230, 0.2146028712590, 0.006653791709700 ]
+ans(1:nrow, 4) = [ 0.2146028712590, 0.2146028712590, 0.3561913862230, 0.006653791709700 ]
+ans(1:nrow, 5) = [ 0.0406739585346, 0.0406739585346, 0.0406739585346, 0.001679535175883 ]
+ans(1:nrow, 6) = [ 0.8779781243960, 0.0406739585346, 0.0406739585346, 0.001679535175883 ]
+ans(1:nrow, 7) = [ 0.0406739585346, 0.8779781243960, 0.0406739585346, 0.001679535175883 ]
+ans(1:nrow, 8) = [ 0.0406739585346, 0.0406739585346, 0.8779781243960, 0.001679535175883 ]
+ans(1:nrow, 9) = [ 0.3223378901420, 0.3223378901420, 0.3223378901420, 0.009226196923950 ]
+ans(1:nrow, 10) = [ 0.0329863295732, 0.3223378901420, 0.3223378901420, 0.009226196923950 ]
+ans(1:nrow, 11) = [ 0.3223378901420, 0.0329863295732, 0.3223378901420, 0.009226196923950 ]
+ans(1:nrow, 12) = [ 0.3223378901420, 0.3223378901420, 0.0329863295732, 0.009226196923950 ]
+ans(1:nrow, 13) = [ 0.0636610018750, 0.0636610018750, 0.2696723314580, 0.008035714285717 ]
+ans(1:nrow, 14) = [ 0.0636610018750, 0.2696723314580, 0.0636610018750, 0.008035714285717 ]
+ans(1:nrow, 15) = [ 0.0636610018750, 0.0636610018750, 0.6030056647920, 0.008035714285717 ]
+ans(1:nrow, 16) = [ 0.0636610018750, 0.6030056647920, 0.0636610018750, 0.008035714285717 ]
+ans(1:nrow, 17) = [ 0.0636610018750, 0.2696723314580, 0.6030056647920, 0.008035714285717 ]
+ans(1:nrow, 18) = [ 0.0636610018750, 0.6030056647920, 0.2696723314580, 0.008035714285717 ]
+ans(1:nrow, 19) = [ 0.2696723314580, 0.0636610018750, 0.0636610018750, 0.008035714285717 ]
+ans(1:nrow, 20) = [ 0.2696723314580, 0.0636610018750, 0.6030056647920, 0.008035714285717 ]
+ans(1:nrow, 21) = [ 0.2696723314580, 0.6030056647920, 0.0636610018750, 0.008035714285717 ]
+ans(1:nrow, 22) = [ 0.6030056647920, 0.0636610018750, 0.2696723314580, 0.008035714285717 ]
+ans(1:nrow, 23) = [ 0.6030056647920, 0.0636610018750, 0.0636610018750, 0.008035714285717 ]
+ans(1:nrow, 24) = [ 0.6030056647920, 0.2696723314580, 0.0636610018750, 0.08035714285717 ]
+
+END SUBROUTINE QP_Tetrahedron_Order6
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90
new file mode 100644
index 000000000..a2954187c
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order7.F90
@@ -0,0 +1,41 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order7(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 31)
+ nrow = 4; ncol = 31
+
+ans(1:nrow, 1) = [ 0.50000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685 ]
+ans(1:nrow, 2) = [ 0.50000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685 ]
+ans(1:nrow, 3) = [ 0.00000000000000, 0.50000000000000, 0.50000000000000, +0.000970017636685 ]
+ans(1:nrow, 4) = [ 0.00000000000000, 0.00000000000000, 0.50000000000000, +0.000970017636685 ]
+ans(1:nrow, 5) = [ 0.00000000000000, 0.50000000000000, 0.00000000000000, +0.000970017636685 ]
+ans(1:nrow, 6) = [ 0.50000000000000, 0.00000000000000, 0.00000000000000, +0.000970017636685 ]
+ans(1:nrow, 7) = [ 0.25000000000000, 0.25000000000000, 0.25000000000000, +0.018264223466167 ]
+ans(1:nrow, 8) = [ 0.07821319233030, 0.07821319233030, 0.07821319233030, +0.010599941524417 ]
+ans(1:nrow, 9) = [ 0.07821319233030, 0.07821319233030, 0.76536042300900, +0.010599941524417 ]
+ans(1:nrow, 10) = [ 0.07821319233030, 0.76536042300900, 0.07821319233030, +0.010599941524417 ]
+ans(1:nrow, 11) = [ 0.76536042300900, 0.07821319233030, 0.07821319233030, +0.010599941524417 ]
+ans(1:nrow, 12) = [ 0.12184321666400, 0.12184321666400, 0.12184321666400, -0.062517740114333 ]
+ans(1:nrow, 13) = [ 0.12184321666400, 0.12184321666400, 0.63447035000800, -0.062517740114333 ]
+ans(1:nrow, 14) = [ 0.12184321666400, 0.63447035000800, 0.12184321666400, -0.062517740114333 ]
+ans(1:nrow, 15) = [ 0.63447035000800, 0.12184321666400, 0.12184321666400, -0.062517740114333 ]
+ans(1:nrow, 16) = [ 0.33253916444600, 0.33253916444600, 0.33253916444600, +0.004891425263067 ]
+ans(1:nrow, 17) = [ 0.33253916444600, 0.33253916444600, 0.00238250666074, +0.004891425263067 ]
+ans(1:nrow, 18) = [ 0.33253916444600, 0.00238250666074, 0.33253916444600, +0.004891425263067 ]
+ans(1:nrow, 19) = [ 0.00238250666074, 0.33253916444600, 0.33253916444600, +0.004891425263067 ]
+ans(1:nrow, 20) = [ 0.10000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000 ]
+ans(1:nrow, 21) = [ 0.10000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000 ]
+ans(1:nrow, 22) = [ 0.10000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000 ]
+ans(1:nrow, 23) = [ 0.10000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000 ]
+ans(1:nrow, 24) = [ 0.10000000000000, 0.20000000000000, 0.60000000000000, +0.027557319224000 ]
+ans(1:nrow, 25) = [ 0.10000000000000, 0.60000000000000, 0.20000000000000, +0.027557319224000 ]
+ans(1:nrow, 26) = [ 0.20000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000 ]
+ans(1:nrow, 27) = [ 0.20000000000000, 0.10000000000000, 0.60000000000000, +0.027557319224000 ]
+ans(1:nrow, 28) = [ 0.20000000000000, 0.60000000000000, 0.10000000000000, +0.027557319224000 ]
+ans(1:nrow, 29) = [ 0.60000000000000, 0.10000000000000, 0.20000000000000, +0.027557319224000 ]
+ans(1:nrow, 30) = [ 0.60000000000000, 0.10000000000000, 0.10000000000000, +0.027557319224000 ]
+ans(1:nrow, 31) = [ 0.60000000000000, 0.20000000000000, 0.10000000000000, +0.027557319224000 ]
+
+END SUBROUTINE QP_Tetrahedron_Order7
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90
new file mode 100644
index 000000000..b5c57003b
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order8.F90
@@ -0,0 +1,53 @@
+
+PURE SUBROUTINE QP_Tetrahedron_Order8(ans, nrow, ncol)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 43)
+ nrow = 4; ncol = 43
+
+ans(1:nrow, 1) = [ 0.2500000000000, 0.2500000000000, 0.2500000000000, -0.020500188658667 ]
+ans(1:nrow, 2) = [ 0.2068299316110, 0.2068299316110, 0.2068299316110, +0.014250305822867 ]
+ans(1:nrow, 3) = [ 0.2068299316110, 0.2068299316110, 0.3795102051680, +0.014250305822867 ]
+ans(1:nrow, 4) = [ 0.2068299316110, 0.3795102051680, 0.2068299316110, +0.014250305822867 ]
+ans(1:nrow, 5) = [ 0.3795102051680, 0.2068299316110, 0.2068299316110, +0.014250305822867 ]
+ans(1:nrow, 6) = [ 0.0821035883105, 0.0821035883105, 0.0821035883105, +0.001967033313133 ]
+ans(1:nrow, 7) = [ 0.0821035883105, 0.0821035883105, 0.7536892350680, +0.001967033313133 ]
+ans(1:nrow, 8) = [ 0.0821035883105, 0.7536892350680, 0.0821035883105, +0.001967033313133 ]
+ans(1:nrow, 9) = [ 0.7536892350680, 0.0821035883105, 0.0821035883105, +0.001967033313133 ]
+ans(1:nrow, 10) = [ 0.0057819505052, 0.0057819505052, 0.0057819505052, +0.000169834109093 ]
+ans(1:nrow, 11) = [ 0.0057819505052, 0.0057819505052, 0.9826541484840, +0.000169834109093 ]
+ans(1:nrow, 12) = [ 0.0057819505052, 0.9826541484840, 0.0057819505052, +0.000169834109093 ]
+ans(1:nrow, 13) = [ 0.9826541484840, 0.0057819505052, 0.0057819505052, +0.000169834109093 ]
+ans(1:nrow, 14) = [ 0.0505327400189, 0.0505327400189, 0.4494672599810, +0.004579683824467 ]
+ans(1:nrow, 15) = [ 0.0505327400189, 0.4494672599810, 0.0505327400189, +0.004579683824467 ]
+ans(1:nrow, 16) = [ 0.4494672599810, 0.0505327400189, 0.0505327400189, +0.004579683824467 ]
+ans(1:nrow, 17) = [ 0.0505327400189, 0.4494672599810, 0.4494672599810, +0.004579683824467 ]
+ans(1:nrow, 18) = [ 0.4494672599810, 0.0505327400189, 0.4494672599810, +0.004579683824467 ]
+ans(1:nrow, 19) = [ 0.4494672599810, 0.4494672599810, 0.0505327400189, +0.004579683824467 ]
+ans(1:nrow, 20) = [ 0.2290665361170, 0.2290665361170, 0.0356395827885, +0.005704485808683 ]
+ans(1:nrow, 21) = [ 0.2290665361170, 0.0356395827885, 0.2290665361170, +0.005704485808683 ]
+ans(1:nrow, 22) = [ 0.2290665361170, 0.2290665361170, 0.5062273449780, +0.005704485808683 ]
+ans(1:nrow, 23) = [ 0.2290665361170, 0.5062273449780, 0.2290665361170, +0.005704485808683 ]
+ans(1:nrow, 24) = [ 0.2290665361170, 0.0356395827885, 0.5062273449780, +0.005704485808683 ]
+ans(1:nrow, 25) = [ 0.2290665361170, 0.5062273449780, 0.0356395827885, +0.005704485808683 ]
+ans(1:nrow, 26) = [ 0.0356395827885, 0.2290665361170, 0.2290665361170, +0.005704485808683 ]
+ans(1:nrow, 27) = [ 0.0356395827885, 0.2290665361170, 0.5062273449780, +0.005704485808683 ]
+ans(1:nrow, 28) = [ 0.0356395827885, 0.5062273449780, 0.2290665361170, +0.005704485808683 ]
+ans(1:nrow, 29) = [ 0.5062273449780, 0.2290665361170, 0.0356395827885, +0.005704485808683 ]
+ans(1:nrow, 30) = [ 0.5062273449780, 0.2290665361170, 0.2290665361170, +0.005704485808683 ]
+ans(1:nrow, 31) = [ 0.5062273449780, 0.0356395827885, 0.2290665361170, +0.005704485808683 ]
+ans(1:nrow, 32) = [ 0.0366077495532, 0.0366077495532, 0.1904860419350, +0.002140519141167 ]
+ans(1:nrow, 33) = [ 0.0366077495532, 0.1904860419350, 0.0366077495532, +0.002140519141167 ]
+ans(1:nrow, 34) = [ 0.0366077495532, 0.0366077495532, 0.7362984589590, +0.002140519141167 ]
+ans(1:nrow, 35) = [ 0.0366077495532, 0.7362984589590, 0.0366077495532, +0.002140519141167 ]
+ans(1:nrow, 36) = [ 0.0366077495532, 0.1904860419350, 0.7362984589590, +0.002140519141167 ]
+ans(1:nrow, 37) = [ 0.0366077495532, 0.7362984589590, 0.1904860419350, +0.002140519141167 ]
+ans(1:nrow, 38) = [ 0.1904860419350, 0.0366077495532, 0.0366077495532, +0.002140519141167 ]
+ans(1:nrow, 39) = [ 0.1904860419350, 0.0366077495532, 0.7362984589590, +0.002140519141167 ]
+ans(1:nrow, 40) = [ 0.1904860419350, 0.7362984589590, 0.0366077495532, +0.002140519141167 ]
+ans(1:nrow, 41) = [ 0.7362984589590, 0.0366077495532, 0.1904860419350, +0.002140519141167 ]
+ans(1:nrow, 42) = [ 0.7362984589590, 0.0366077495532, 0.0366077495532, +0.002140519141167 ]
+ans(1:nrow, 43) = [ 0.7362984589590, 0.1904860419350, 0.0366077495532, +0.002140519141167 ]
+
+END SUBROUTINE QP_Tetrahedron_Order8
diff --git a/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90 b/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90
new file mode 100644
index 000000000..73fe78efe
--- /dev/null
+++ b/src/submodules/Polynomial/src/include/Tetrahedron/order9.F90
@@ -0,0 +1,62 @@
+PURE subroutine QP_Tetrahedron_Order9(ans, nrow, ncol)
+ real(DFP), intent(INOUT) :: ans(:, :)
+ integer(I4B), intent(OUT) :: nrow, ncol
+
+ !! REAL(DFP) :: ans(4, 53)
+ nrow=4;ncol= 53
+
+ans(1:nrow, 1) = [ +0.25000000000000, +0.25000000000000, +0.25000000000000 , -0.137799038326167 ]
+ans(1:nrow, 2) = [ +0.04835103854970, +0.04835103854970, +0.04835103854970 , +0.001865336569083 ]
+ans(1:nrow, 3) = [ +0.04835103854970, +0.04835103854970, +0.85494688435100 , +0.001865336569083 ]
+ans(1:nrow, 4) = [ +0.04835103854970, +0.85494688435100, +0.04835103854970 , +0.001865336569083 ]
+ans(1:nrow, 5) = [ +0.85494688435100, +0.04835103854970, +0.04835103854970 , +0.001865336569083 ]
+ans(1:nrow, 6) = [ +0.32457928011800, +0.32457928011800, +0.32457928011800 , +0.004309423969500 ]
+ans(1:nrow, 7) = [ +0.32457928011800, +0.32457928011800, +0.02626215964640 , +0.004309423969500 ]
+ans(1:nrow, 8) = [ +0.32457928011800, +0.02626215964640, +0.32457928011800 , +0.004309423969500 ]
+ans(1:nrow, 9) = [ +0.02626215964640, +0.32457928011800, +0.32457928011800 , +0.004309423969500 ]
+ans(1:nrow, 10) = [ +0.11461654022400, +0.11461654022400, +0.11461654022400 , -0.090184766481167 ]
+ans(1:nrow, 11) = [ +0.11461654022400, +0.11461654022400, +0.65615037932800 , -0.090184766481167 ]
+ans(1:nrow, 12) = [ +0.11461654022400, +0.65615037932800, +0.11461654022400 , -0.090184766481167 ]
+ans(1:nrow, 13) = [ +0.65615037932800, +0.11461654022400, +0.11461654022400 , -0.090184766481167 ]
+ans(1:nrow, 14) = [ +0.22548995191200, +0.22548995191200, +0.22548995191200 , +0.044672576202500 ]
+ans(1:nrow, 15) = [ +0.22548995191200, +0.22548995191200, +0.32353014426500 , +0.044672576202500 ]
+ans(1:nrow, 16) = [ +0.22548995191200, +0.32353014426500, +0.22548995191200 , +0.044672576202500 ]
+ans(1:nrow, 17) = [ +0.32353014426500, +0.22548995191200, +0.22548995191200 , +0.044672576202500 ]
+ans(1:nrow, 18) = [ +0.13162780924700, +0.13162780924700, +0.08366470161720 , +0.034700405884500 ]
+ans(1:nrow, 19) = [ +0.13162780924700, +0.08366470161720, +0.13162780924700 , +0.034700405884500 ]
+ans(1:nrow, 20) = [ +0.13162780924700, +0.13162780924700, +0.65307967988900 , +0.034700405884500 ]
+ans(1:nrow, 21) = [ +0.13162780924700, +0.65307967988900, +0.13162780924700 , +0.034700405884500 ]
+ans(1:nrow, 22) = [ +0.13162780924700, +0.08366470161720, +0.65307967988900 , +0.034700405884500 ]
+ans(1:nrow, 23) = [ +0.13162780924700, +0.65307967988900, +0.08366470161720 , +0.034700405884500 ]
+ans(1:nrow, 24) = [ +0.08366470161720, +0.13162780924700, +0.13162780924700 , +0.034700405884500 ]
+ans(1:nrow, 25) = [ +0.08366470161720, +0.13162780924700, +0.65307967988900 , +0.034700405884500 ]
+ans(1:nrow, 26) = [ +0.08366470161720, +0.65307967988900, +0.13162780924700 , +0.034700405884500 ]
+ans(1:nrow, 27) = [ +0.65307967988900, +0.13162780924700, +0.08366470161720 , +0.034700405884500 ]
+ans(1:nrow, 28) = [ +0.65307967988900, +0.13162780924700, +0.13162780924700 , +0.034700405884500 ]
+ans(1:nrow, 29) = [ +0.65307967988900, +0.08366470161720, +0.13162780924700 , +0.034700405884500 ]
+ans(1:nrow, 30) = [ +0.43395146141100, +0.43395146141100, +0.10776985954900 , +0.003352583902667 ]
+ans(1:nrow, 31) = [ +0.43395146141100, +0.10776985954900, +0.43395146141100 , +0.003352583902667 ]
+ans(1:nrow, 32) = [ +0.43395146141100, +0.43395146141100, +0.02432721762780 , +0.003352583902667 ]
+ans(1:nrow, 33) = [ +0.43395146141100, +0.02432721762780, +0.43395146141100 , +0.003352583902667 ]
+ans(1:nrow, 34) = [ +0.43395146141100, +0.10776985954900, +0.02432721762780 , +0.003352583902667 ]
+ans(1:nrow, 35) = [ +0.43395146141100, +0.02432721762780, +0.10776985954900 , +0.003352583902667 ]
+ans(1:nrow, 36) = [ +0.10776985954900, +0.43395146141100, +0.43395146141100 , +0.003352583902667 ]
+ans(1:nrow, 37) = [ +0.10776985954900, +0.43395146141100, +0.02432721762780 , +0.003352583902667 ]
+ans(1:nrow, 38) = [ +0.10776985954900, +0.02432721762780, +0.43395146141100 , +0.003352583902667 ]
+ans(1:nrow, 39) = [ +0.02432721762780, +0.43395146141100, +0.10776985954900 , +0.003352583902667 ]
+ans(1:nrow, 40) = [ +0.02432721762780, +0.43395146141100, +0.43395146141100 , +0.003352583902667 ]
+ans(1:nrow, 41) = [ +0.02432721762780, +0.10776985954900, +0.43395146141100 , +0.003352583902667 ]
+ans(1:nrow, 42) = [ -0.00137627731814, -0.00137627731814, +0.27655347263700 , +0.000431628875557 ]
+ans(1:nrow, 43) = [ -0.00137627731814, +0.27655347263700, -0.00137627731814 , +0.000431628875557 ]
+ans(1:nrow, 44) = [ -0.00137627731814, -0.00137627731814, +0.72619908199900 , +0.000431628875557 ]
+ans(1:nrow, 45) = [ -0.00137627731814, +0.72619908199900, -0.00137627731814 , +0.000431628875557 ]
+ans(1:nrow, 46) = [ -0.00137627731814, +0.27655347263700, +0.72619908199900 , +0.000431628875557 ]
+ans(1:nrow, 47) = [ -0.00137627731814, +0.72619908199900, +0.27655347263700 , +0.000431628875557 ]
+ans(1:nrow, 48) = [ +0.27655347263700, -0.00137627731814, -0.00137627731814 , +0.000431628875557 ]
+ans(1:nrow, 49) = [ +0.27655347263700, -0.00137627731814, +0.72619908199900 , +0.000431628875557 ]
+ans(1:nrow, 50) = [ +0.27655347263700, +0.72619908199900, -0.00137627731814 , +0.000431628875557 ]
+ans(1:nrow, 51) = [ +0.72619908199900, -0.00137627731814, +0.27655347263700 , +0.000431628875557 ]
+ans(1:nrow, 52) = [ +0.72619908199900, -0.00137627731814, -0.00137627731814 , +0.000431628875557 ]
+ans(1:nrow, 53) = [ +0.72619908199900, +0.27655347263700, -0.00137627731814 , +0.000431628875557 ]
+
+END subroutine QP_Tetrahedron_Order9
diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt
index 69ce7a34f..9e9866be4 100644
--- a/src/submodules/QuadraturePoint/CMakeLists.txt
+++ b/src/submodules/QuadraturePoint/CMakeLists.txt
@@ -1,25 +1,23 @@
-# This program is a part of EASIFEM library
-# Copyright (C) 2020-2021 Vikas Sharma, Ph.D
+# 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 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.
+# 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
+# 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}/QuadraturePoint_Method@IOMethods.F90
- ${src_path}/QuadraturePoint_Method@GetMethods.F90
- ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90
-)
-
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/QuadraturePoint_Method@IOMethods.F90
+ ${src_path}/QuadraturePoint_Method@GetMethods.F90
+ ${src_path}/QuadraturePoint_Method@ConstructorMethods.F90)
diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90
index 9387b1aab..38be36089 100755
--- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90
@@ -20,8 +20,36 @@
! summary: Constructor methods for [[QuadraturePoint_]]
SUBMODULE(QuadraturePoint_Method) ConstructorMethods
-USE BaseMethod
+USE GlobalData, ONLY: stderr
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE BaseInterpolation_Method, ONLY: BaseInterpolation_ToString, &
+ BaseInterpolation_ToInteger, &
+ BaseInterpolation_ToChar
+USE ReallocateUtility, ONLY: Reallocate
+
+USE ReferenceElement_Method, ONLY: ElementTopology, &
+ XiDimension
+
+USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, &
+ QuadraturePoint_Line_
+USE TriangleInterpolationUtility, ONLY: QuadraturePoint_Triangle_, &
+ QuadratureNumber_Triangle
+
+USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_, &
+ QuadratureNumber_Quadrangle
+
+USE TetrahedronInterpolationUtility, ONLY: QuadraturePoint_Tetrahedron_, &
+ QuadratureNumber_Tetrahedron
+
+USE HexahedronInterpolationUtility, ONLY: QuadraturePoint_Hexahedron_, &
+ QuadratureNumber_Hexahedron
+
+USE BaseType, ONLY: elem => TypeElemNameOpt
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -32,6 +60,14 @@
ans = BaseInterpolation_ToString(name)
END PROCEDURE QuadraturePointIDToName
+!----------------------------------------------------------------------------
+! QuadraturePointIDToName
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_ToChar
+ans = BaseInterpolation_ToChar(name)
+END PROCEDURE QuadraturePoint_ToChar
+
!----------------------------------------------------------------------------
! QuadraturePointNameToID
!----------------------------------------------------------------------------
@@ -41,924 +77,377 @@
END PROCEDURE QuadraturePointNameToID
!----------------------------------------------------------------------------
-! Initiate
+! QuadraturePoint
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate1
+MODULE PROCEDURE quad_Constructor1
obj%points = points
obj%tXi = SIZE(points, 1) - 1
-! No of row minus one
-END PROCEDURE quad_initiate1
+END PROCEDURE quad_Constructor1
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Pointer
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE quad_Constructor_1
+ALLOCATE (obj)
+obj%points = points
+obj%tXi = SIZE(points, 1) - 1
+END PROCEDURE quad_Constructor_1
+
+!----------------------------------------------------------------------------
+! Deallocate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE quad_Deallocate
+IF (ALLOCATED(obj%points)) DEALLOCATE (obj%points)
+obj%tXi = -1
+END PROCEDURE quad_Deallocate
+
+!----------------------------------------------------------------------------
+! QuadraturePoint
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_QuadratureNumber1
+INTEGER(I4B) :: ncol
+
+SELECT CASE (topo)
+
+CASE (elem%line)
+
+ ans = QuadratureNumber_Line(order=order, quadtype=quadratureType)
+
+CASE (elem%triangle)
+
+ ans = QuadratureNumber_Triangle(order=order, quadtype=quadratureType)
+
+CASE (elem%quadrangle)
+
+ ans = QuadratureNumber_Line(order=order, quadtype=quadratureType)
+
+CASE (elem%tetrahedron)
+
+ ans = QuadratureNumber_Tetrahedron(order=order, quadtype=quadratureType)
+
+! CASE (elem%hexahedron)
+!
+! CASE (elem%prism)
+!
+! CASE (elem%pyramid)
+
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, routine="obj_QuadratureNumber1()", line=__LINE__, &
+ unitno=stderr)
+ STOP
+
+END SELECT
+
+END PROCEDURE obj_QuadratureNumber1
+
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Initiate1
+INTEGER(I4B) :: nrow, ncol
+
+nrow = SIZE(points, 1)
+ncol = SIZE(points, 2)
+
+CALL Reallocate(obj%points, nrow, ncol)
+
+obj%points(1:nrow, 1:ncol) = points
+obj%tXi = nrow - 1
+END PROCEDURE obj_Initiate1
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate2
+MODULE PROCEDURE obj_Initiate2
obj%tXi = tXi
CALL Reallocate(obj%points, tXi + 1, tpoints)
-END PROCEDURE quad_initiate2
+END PROCEDURE obj_Initiate2
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate3
+MODULE PROCEDURE obj_Initiate3
INTEGER(I4B) :: quadType
+
quadType = QuadraturePointNameToId(quadratureType)
-CALL Initiate( &
- & obj=obj, &
- & refElem=refElem, &
- & order=order, &
- & quadratureType=quadType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END PROCEDURE quad_initiate3
+CALL Initiate(obj=obj, refElem=refElem, order=order, &
+ quadratureType=quadType, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE obj_Initiate3
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate4
+MODULE PROCEDURE obj_Initiate4
INTEGER(I4B) :: quadType
quadType = QuadraturePointNameToId(quadratureType)
-CALL Initiate( &
- & obj=obj, &
- & refElem=refElem, &
- & nips=nips, &
- & quadratureType=quadType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END PROCEDURE quad_initiate4
+CALL Initiate(obj=obj, refElem=refElem, nips=nips, &
+ quadratureType=quadType, alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE obj_Initiate4
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate5
-
-SELECT TYPE (refelem)
-TYPE IS (ReferenceLine_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & order=order, &
- & quadType=quadratureType, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
-
-TYPE IS (ReferenceTriangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & order=order, &
- & quadType=quadratureType, &
- & refTriangle=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceQuadrangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & order=order, &
- & quadType=quadratureType, &
- & refQuadrangle=refelem%domainName, &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
-
-TYPE IS (ReferenceTetrahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & order=order, &
- & quadType=quadratureType, &
- & refTetrahedron=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceHexahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & order=order, &
- & quadType=quadratureType, &
- & refHexahedron=refelem%domainName, &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
-
-TYPE IS (ReferencePrism_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & order=order, &
- & quadType=quadratureType, &
- & refPrism=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferencePyramid_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & order=order, &
- & quadType=quadratureType, &
- & refPyramid=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceElement_)
-
- IF (isLine(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & order=order, &
- & quadType=quadratureType, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
- RETURN
- END IF
-
- IF (isTriangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & order=order, &
- & quadType=quadratureType, &
- & refTriangle=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isQuadrangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & order=order, &
- & quadType=quadratureType, &
- & refQuadrangle=refelem%domainName, &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
- RETURN
- END IF
-
- IF (isTetrahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & order=order, &
- & quadType=quadratureType, &
- & refTetrahedron=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isHexahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & order=order, &
- & quadType=quadratureType, &
- & refHexahedron=refelem%domainName, &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
- RETURN
- END IF
-
- IF (isPrism(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & order=order, &
- & quadType=quadratureType, &
- & refPrism=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isPyramid(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & order=order, &
- & quadType=quadratureType, &
- & refPyramid=refelem%domainName, &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
-CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="[NO CASE FOUND] for the type of refelem", &
- & file=__FILE__, &
- & routine="quad_initiate5()", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END SELECT
+MODULE PROCEDURE obj_Initiate5
+CALL obj_Initiate9(obj=obj, elemType=refelem%name, &
+ domainName=refelem%domainName, order=order, quadratureType=quadratureType, &
+ alpha=alpha, beta=beta, lambda=lambda, xij=refelem%xij)
+END PROCEDURE obj_Initiate5
-END PROCEDURE quad_initiate5
-
-!----------------------------------------------------------------------------
-! Initiate
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE quad_initiate6
-
-SELECT TYPE (refelem)
-TYPE IS (ReferenceLine_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & nips=nips, &
- & quadType=quadratureType, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
-
-TYPE IS (ReferenceTriangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refTriangle="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceQuadrangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refQuadrangle="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
-
-TYPE IS (ReferenceTetrahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refTetrahedron="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceHexahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refHexahedron="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
-
-TYPE IS (ReferencePrism_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refPrism="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferencePyramid_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refPyramid="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceElement_)
-
- IF (isLine(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & nips=nips, &
- & quadType=quadratureType, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
- RETURN
- END IF
-
- IF (isTriangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refTriangle="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isQuadrangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refQuadrangle="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
- RETURN
- END IF
-
- IF (isTetrahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refTetrahedron="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isHexahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refHexahedron="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda) &
- & )
- RETURN
- END IF
-
- IF (isPrism(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refPrism="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isPyramid(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & nips=nips, &
- & quadType=quadratureType, &
- & refPyramid="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
-CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="No case found", &
- & file=__FILE__, &
- & routine="quad_initiate6()", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END SELECT
-
-END PROCEDURE quad_initiate6
-
-!----------------------------------------------------------------------------
-! QuadraturePoint
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE quad_initiate7
-
-SELECT TYPE (refelem)
-TYPE IS (ReferenceLine_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & order=p, &
- & quadType=quadratureType1, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1) &
- & )
-
-TYPE IS (ReferenceTriangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & order=p, &
- & quadType=quadratureType1, &
- & refTriangle="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceQuadrangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & p=p, &
- & q=q, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & refQuadrangle="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2 &
- & ))
-
-TYPE IS (ReferenceTetrahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & order=p, &
- & quadType=quadratureType1, &
- & refTetrahedron="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceHexahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & p=p, &
- & q=q, &
- & r=r, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & quadType3=quadratureType3, &
- & refHexahedron="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2, &
- & alpha3=alpha3, &
- & beta3=beta3, &
- & lambda3=lambda3 &
- & ))
-
-TYPE IS (ReferencePrism_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & order=p, &
- & quadType=quadratureType1, &
- & refPrism="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferencePyramid_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & order=p, &
- & quadType=quadratureType1, &
- & refPyramid="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceElement_)
-
- IF (isLine(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & order=p, &
- & quadType=quadratureType1, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1) &
- & )
- RETURN
- END IF
-
- IF (isTriangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & order=p, &
- & quadType=quadratureType1, &
- & refTriangle="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isQuadrangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & p=p, &
- & q=q, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & refQuadrangle="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2 &
- & ))
- RETURN
- END IF
-
- IF (isTetrahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & order=p, &
- & quadType=quadratureType1, &
- & refTetrahedron="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isHexahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & p=p, &
- & q=q, &
- & r=r, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & quadType3=quadratureType3, &
- & refHexahedron="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2, &
- & alpha3=alpha3, &
- & beta3=beta3, &
- & lambda3=lambda3 &
- & ))
- RETURN
- END IF
-
- IF (isPrism(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & order=p, &
- & quadType=quadratureType1, &
- & refPrism="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isPyramid(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & order=p, &
- & quadType=quadratureType1, &
- & refPyramid="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
-CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="No case found", &
- & file=__FILE__, &
- & routine="quad_initiate7()", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END SELECT
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
-END PROCEDURE quad_initiate7
+MODULE PROCEDURE obj_Initiate6
+CALL obj_Initiate10(obj=obj, elemType=refelem%name, &
+ domainName=refelem%domainName, nips=nips, quadratureType=quadratureType, &
+ alpha=alpha, beta=beta, lambda=lambda, xij=refelem%xij)
+END PROCEDURE obj_Initiate6
!----------------------------------------------------------------------------
-! QuadraturePoint
+! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate8
-
-SELECT TYPE (refelem)
-TYPE IS (ReferenceLine_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1) &
- & )
-
-TYPE IS (ReferenceTriangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refTriangle="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceQuadrangle_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & nipsx=nipsx, &
- & nipsy=nipsy, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & refQuadrangle="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2 &
- & ))
-
-TYPE IS (ReferenceTetrahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refTetrahedron="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceHexahedron_)
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & nipsx=nipsx, &
- & nipsy=nipsy, &
- & nipsz=nipsz, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & quadType3=quadratureType3, &
- & refHexahedron="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2, &
- & alpha3=alpha3, &
- & beta3=beta3, &
- & lambda3=lambda3 &
- & ))
-
-TYPE IS (ReferencePrism_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refPrism="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferencePyramid_)
-
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refPyramid="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
-
-TYPE IS (ReferenceElement_)
-
- IF (isLine(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Line( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & layout="INCREASING", &
- & xij=LocalNodeCoord(refElem), &
- & alpha=alpha1, &
- & beta=beta1, &
- & lambda=lambda1) &
- & )
- RETURN
- END IF
-
- IF (isTriangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Triangle( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refTriangle="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isQuadrangle(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Quadrangle( &
- & nipsx=nipsx, &
- & nipsy=nipsy, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & refQuadrangle="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2 &
- & ))
- RETURN
- END IF
-
- IF (isTetrahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Tetrahedron( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refTetrahedron="UNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isHexahedron(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Hexahedron( &
- & nipsx=nipsx, &
- & nipsy=nipsy, &
- & nipsz=nipsz, &
- & quadType1=quadratureType1, &
- & quadType2=quadratureType2, &
- & quadType3=quadratureType3, &
- & refHexahedron="BIUNIT", &
- & xij=LocalNodeCoord(refElem), &
- & alpha1=alpha1, &
- & beta1=beta1, &
- & lambda1=lambda1, &
- & alpha2=alpha2, &
- & beta2=beta2, &
- & lambda2=lambda2, &
- & alpha3=alpha3, &
- & beta3=beta3, &
- & lambda3=lambda3 &
- & ))
- RETURN
- END IF
-
- IF (isPrism(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Prism( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refPrism="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
- IF (isPyramid(refelem%name)) THEN
- CALL Initiate( &
- & obj=obj, &
- & points=QuadraturePoint_Pyramid( &
- & nips=nipsx, &
- & quadType=quadratureType1, &
- & refPyramid="BIUNIT", &
- & xij=LocalNodeCoord(refElem)) &
- & )
- RETURN
- END IF
-
-CLASS DEFAULT
- CALL ErrorMsg(&
- & msg="No case found", &
- & file=__FILE__, &
- & routine="quad_initiate7()", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END SELECT
+MODULE PROCEDURE obj_Initiate8
+CALL obj_Initiate12(obj=obj, elemType=refelem%name, &
+ domainName=refelem%domainName, nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadratureType1=quadratureType1, quadratureType2=quadratureType2, &
+ quadratureType3=quadratureType3, alpha1=alpha1, beta1=beta1, &
+ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ alpha3=alpha3, beta3=beta3, lambda3=lambda3, xij=refelem%xij)
+END PROCEDURE obj_Initiate8
+
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
-END PROCEDURE quad_initiate8
+MODULE PROCEDURE obj_Initiate9
+CALL obj_Initiate11(obj=obj, elemType=elemtype, domainName=domainname, &
+ p=order, q=order, r=order, quadratureType1=quadratureType, &
+ quadratureType2=quadratureType, quadratureType3=quadratureType, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, &
+ lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, xij=xij)
+END PROCEDURE obj_Initiate9
!----------------------------------------------------------------------------
-! QuadraturePoint
+! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_Constructor1
-obj%points = points
-obj%tXi = SIZE(points, 1) - 1
-END PROCEDURE quad_Constructor1
+MODULE PROCEDURE obj_Initiate10
+CALL obj_Initiate12(obj=obj, elemType=elemtype, domainName=domainName, &
+ nipsx=nips, nipsy=nips, nipsz=nips, quadratureType1=quadratureType, &
+ quadratureType2=quadratureType, quadratureType3=quadratureType, &
+ alpha1=alpha, beta1=beta, lambda1=lambda, alpha2=alpha, beta2=beta, &
+ lambda2=lambda, alpha3=alpha, beta3=beta, lambda3=lambda, xij=xij)
+END PROCEDURE obj_Initiate10
!----------------------------------------------------------------------------
-! QuadraturePoint_Pointer
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_Constructor_1
-ALLOCATE (obj)
-obj%points = points
-obj%tXi = SIZE(points, 1) - 1
-END PROCEDURE quad_Constructor_1
+MODULE PROCEDURE obj_Initiate11
+INTEGER(I4B) :: topo, nrow, ncol, ii, nipsx(1), nipsy(1), nipsz(1)
+
+topo = ElementTopology(elemType)
+
+ii = XiDimension(elemType)
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), ii)
+ELSE
+ nrow = ii
+END IF
+
+nrow = nrow + 1
+
+SELECT CASE (topo)
+
+CASE (elem%line)
+
+ nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1)
+
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadratureType1, &
+ layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, &
+ lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%triangle)
+
+ nipsx(1) = QuadratureNumber_Triangle(order=p, quadtype=quadratureType1)
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, &
+ refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%quadrangle)
+
+ nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1)
+ nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2)
+
+ ncol = nipsx(1) * nipsy(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, &
+ quadType1=quadratureType1, quadType2=quadratureType2, &
+ refQuadrangle=domainName, xij=xij, alpha1=alpha1, beta1=beta1, &
+ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%tetrahedron)
+
+ nipsx(1) = QuadratureNumber_Tetrahedron(order=p, quadtype=quadratureType1)
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, &
+ refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%hexahedron)
+
+ nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1)
+ nipsy(1) = QuadratureNumber_Line(order=q, quadtype=quadratureType2)
+ nipsz(1) = QuadratureNumber_Line(order=r, quadtype=quadratureType3)
+
+ ncol = nipsx(1) * nipsy(1) * nipsz(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadType1=quadratureType1, &
+ quadType2=quadratureType2, &
+ quadType3=quadratureType3, &
+ refHexahedron=domainName, xij=xij, &
+ alpha1=alpha1, beta1=beta1, lambda1=lambda1, &
+ alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ alpha3=alpha3, beta3=beta3, lambda3=lambda3, &
+ ans=obj%points, nrow=nrow, ncol=ncol)
+
+! CASE (Prism)
+
+! CASE (Pyramid)
+
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, routine="obj_Initiate11()", line=__LINE__, &
+ unitno=stderr)
+ STOP
+
+END SELECT
+
+obj%txi = SIZE(obj%points, 1) - 1
+
+END PROCEDURE obj_Initiate11
!----------------------------------------------------------------------------
-! Deallocate
+!
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_Deallocate
-IF (ALLOCATED(obj%points)) DEALLOCATE (obj%points)
-obj%tXi = -1
-END PROCEDURE quad_Deallocate
+MODULE PROCEDURE obj_Initiate12
+INTEGER(I4B) :: topo, nrow, ncol, ii
+
+topo = ElementTopology(elemType)
+
+ii = XiDimension(elemType)
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), ii)
+ELSE
+ nrow = ii
+END IF
+
+nrow = nrow + 1
+
+SELECT CASE (topo)
+
+CASE (elem%line)
+ ncol = nipsx(1)
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Line_(nips=nipsx, quadType=quadratureType1, &
+ layout="INCREASING", xij=xij, alpha=alpha1, beta=beta1, &
+ lambda=lambda1, ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%triangle)
+
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Triangle_(nips=nipsx, quadType=quadratureType1, &
+ refTriangle=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%quadrangle)
+
+ ncol = nipsx(1) * nipsy(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Quadrangle_(nipsx=nipsx, nipsy=nipsy, &
+ quadType1=quadratureType1, quadType2=quadratureType2, &
+ refQuadrangle=domainName, xij=xij, alpha1=alpha1, beta1=beta1, &
+ lambda1=lambda1, alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%tetrahedron)
+
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Tetrahedron_(nips=nipsx, quadType=quadratureType1, &
+ refTetrahedron=domainName, xij=xij, ans=obj%points, nrow=nrow, ncol=ncol)
+
+CASE (elem%hexahedron)
+
+ ncol = nipsx(1) * nipsy(1) * nipsz(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+
+ CALL QuadraturePoint_Hexahedron_(nipsx=nipsx, nipsy=nipsy, nipsz=nipsz, &
+ quadType1=quadratureType1, &
+ quadType2=quadratureType2, &
+ quadType3=quadratureType3, &
+ refHexahedron=domainName, &
+ xij=xij, &
+ alpha1=alpha1, beta1=beta1, lambda1=lambda1, &
+ alpha2=alpha2, beta2=beta2, lambda2=lambda2, &
+ alpha3=alpha3, beta3=beta3, lambda3=lambda3, &
+ ans=obj%points, nrow=nrow, ncol=ncol)
+
+! CASE (Prism)
+!
+! CASE (Pyramid)
+
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, routine="obj_Initiate12()", line=__LINE__, &
+ unitno=stderr)
+ STOP
+
+END SELECT
+
+obj%txi = SIZE(obj%points, 1) - 1
+
+END PROCEDURE obj_Initiate12
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END SUBMODULE ConstructorMethods
diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90
index 126af77a7..61cc73fc2 100755
--- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90
@@ -20,7 +20,8 @@
! summary: Constructor methods for [[Quadraturepoints_]]
SUBMODULE(QuadraturePoint_Method) GetMethods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
+
IMPLICIT NONE
CONTAINS
@@ -28,46 +29,67 @@
! SIZE
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_Size
+MODULE PROCEDURE obj_Size
ans = SIZE(obj%points, dims)
-END PROCEDURE quad_Size
+END PROCEDURE obj_Size
!----------------------------------------------------------------------------
! getTotalQuadraturepoints
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_getTotalQuadraturepoints
+MODULE PROCEDURE obj_GetTotalQuadraturepoints
ans = SIZE(obj, 2)
-END PROCEDURE quad_getTotalQuadraturepoints
+END PROCEDURE obj_GetTotalQuadraturepoints
!----------------------------------------------------------------------------
! getQuadraturepoints
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_GetQuadraturePoints1
+MODULE PROCEDURE obj_GetQuadraturePoints1
points = 0.0_DFP
points(1:obj%tXi) = obj%points(1:obj%tXi, Num)
weights = obj%points(obj%tXi + 1, Num)
-END PROCEDURE quad_GetQuadraturePoints1
+END PROCEDURE obj_GetQuadraturePoints1
!----------------------------------------------------------------------------
! getQuadraturepoints
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_GetQuadraturePoints2
+MODULE PROCEDURE obj_GetQuadraturePoints2
INTEGER(I4B) :: n
n = SIZE(obj%points, 2) !#column
CALL Reallocate(points, 3, n)
points(1:obj%tXi, 1:n) = obj%points(1:obj%tXi, 1:n)
weights = obj%points(obj%tXi + 1, 1:n)
-END PROCEDURE quad_GetQuadraturePoints2
+END PROCEDURE obj_GetQuadraturePoints2
+
+!----------------------------------------------------------------------------
+! GetQuadratureWeights
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetQuadratureWeights1_
+tsize = SIZE(obj%points, 2) !#column
+weights(1:tsize) = obj%points(obj%tXi + 1, 1:tsize)
+END PROCEDURE obj_GetQuadratureWeights1_
+
+!----------------------------------------------------------------------------
+! getQuadraturepoints
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetQuadraturePoints1_
+nrow = 3
+ncol = SIZE(obj%points, 2) !#column
+
+! CALL Reallocate(points, 3, n)
+points(1:obj%tXi, 1:ncol) = obj%points(1:obj%tXi, 1:ncol)
+weights(1:ncol) = obj%points(obj%tXi + 1, 1:ncol)
+END PROCEDURE obj_GetQuadraturePoints1_
!----------------------------------------------------------------------------
! Outerprod
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_Outerprod
-REAL(DFP), ALLOCATABLE :: points(:, :)
+MODULE PROCEDURE obj_Outerprod
INTEGER(I4B) :: n1, n2, n
INTEGER(I4B) :: ii, a, b
@@ -75,17 +97,22 @@
n2 = SIZE(obj2, 2)
n = n1 * n2
-CALL Reallocate(points, 3, n)
+CALL Reallocate(ans%points, 3, n)
+
DO ii = 1, n1
a = (ii - 1) * n2 + 1
b = ii * n2
- points(1, a:b) = obj1%points(1, ii)
- points(2, a:b) = obj2%points(1, :)
- points(3, a:b) = obj1%points(2, ii) * obj2%points(2, :)
+ ans%points(1, a:b) = obj1%points(1, ii)
+ ans%points(2, a:b) = obj2%points(1, :)
+ ans%points(3, a:b) = obj1%points(2, ii) * obj2%points(2, :)
END DO
-CALL Initiate(obj=ans, points=points)
-IF (ALLOCATED(points)) DEALLOCATE (points)
-END PROCEDURE quad_Outerprod
+! CALL Initiate(obj=ans, points=points)
+ans%tXi = SIZE(ans%points, 1) - 1
+END PROCEDURE obj_Outerprod
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END SUBMODULE GetMethods
diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90
index 698838d8d..acb6f1270 100644
--- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@IOMethods.F90
@@ -20,28 +20,35 @@
! summary: This submodule contains the IO method for [[QuadraturePoint_]]
SUBMODULE(QuadraturePoint_Method) IOMethods
-USE BaseMethod
+USE Display_Method, ONLY: Util_Display => Display, Tostring
+USE MdEncode_Method, ONLY: Util_MdEncode => MdEncode
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
! Display
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_Display
-CALL Display(msg, unitno=unitno)
-IF (.NOT. ALLOCATED(obj%points)) THEN
- RETURN
-END IF
-CALL Display(obj%points, msg="# points :", unitno=unitno)
-CALL Display(obj%txi, msg="# txi :", unitno=unitno)
-END PROCEDURE quad_Display
+MODULE PROCEDURE obj_Display
+LOGICAL(LGT) :: isok
+
+CALL Util_Display(msg, unitno=unitno)
+
+isok = ALLOCATED(obj%points)
+IF (.NOT. isok) RETURN
+
+CALL Util_Display(obj%points, msg="points:", unitno=unitno)
+CALL Util_Display(obj%txi, msg="txi:", unitno=unitno)
+
+END PROCEDURE obj_Display
!----------------------------------------------------------------------------
! MdEncode
!----------------------------------------------------------------------------
-MODULE PROCEDURE QuadraturePoint_MdEncode
+MODULE PROCEDURE obj_MdEncode
INTEGER(I4B) :: ii, n, jj
TYPE(String), ALLOCATABLE :: rh(:), ch(:)
@@ -51,8 +58,10 @@
END IF
n = SIZE(obj%points, 2)
-CALL Reallocate(rh, SIZE(obj, 1))
-CALL Reallocate(ch, SIZE(obj, 2))
+ii = SIZE(obj, 1)
+jj = SIZE(obj, 2)
+
+ALLOCATE (rh(ii), ch(jj))
DO ii = 1, SIZE(rh) - 1
rh(ii) = "`x"//tostring(ii)//"`"
@@ -63,8 +72,12 @@
ch(ii) = "`p"//tostring(ii)//"`"
END DO
-ans = MdEncode(obj%points, rh=rh, ch=ch)
+ans = Util_MdEncode(obj%points, rh=rh, ch=ch)
+
+END PROCEDURE obj_MdEncode
-END PROCEDURE QuadraturePoint_MdEncode
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END SUBMODULE IOMethods
diff --git a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90 b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90
index 32bae5ad0..ab9bb0fa7 100644
--- a/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90
+++ b/src/submodules/RealMatrix/src/RealMatrix_Method@ConstructorMethods.F90
@@ -15,7 +15,7 @@
! along with this program. If not, see
!
-SUBMODULE (RealMatrix_Method) ConstructorMethods
+SUBMODULE(RealMatrix_Method) ConstructorMethods
USE BaseMethod
IMPLICIT NONE
CONTAINS
@@ -25,11 +25,11 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE get_shape
- IF( ALLOCATED( obj%val ) ) THEN
- Ans = SHAPE( obj%val )
- ELSE
- Ans = 0
- END IF
+IF (ALLOCATED(obj%val)) THEN
+ Ans = SHAPE(obj%val)
+ELSE
+ Ans = 0
+END IF
END PROCEDURE get_shape
!----------------------------------------------------------------------------
@@ -37,18 +37,18 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE get_size
- !Define internal variables
- INTEGER( I4B ) :: S( 2 )
- IF( ALLOCATED( obj%val ) ) THEN
- S = SHAPE( obj%val )
- IF( PRESENT( Dims ) ) THEN
- Ans = S( Dims )
- ELSE
- Ans = S( 1 ) * S( 2 )
- END IF
+!Define internal variables
+INTEGER(I4B) :: S(2)
+IF (ALLOCATED(obj%val)) THEN
+ S = SHAPE(obj%val)
+ IF (PRESENT(Dims)) THEN
+ Ans = S(Dims)
ELSE
- Ans = 0
+ Ans = S(1) * S(2)
END IF
+ELSE
+ Ans = 0
+END IF
END PROCEDURE get_size
!----------------------------------------------------------------------------
@@ -56,7 +56,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE get_tdimension
- ans = obj%tDimension
+ans = obj%tDimension
END PROCEDURE get_tdimension
!----------------------------------------------------------------------------
@@ -64,7 +64,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE set_tdimension
- obj%tDimension = tDimension
+obj%tDimension = tDimension
END PROCEDURE set_tdimension
!----------------------------------------------------------------------------
@@ -72,8 +72,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE allocate_data
- CALL Reallocate( obj%val, Dims(1), Dims(2) )
- CALL setTotalDimension( obj, 2_I4B )
+CALL Reallocate(obj%val, Dims(1), Dims(2))
+CALL setTotalDimension(obj, 2_I4B)
END PROCEDURE allocate_data
!----------------------------------------------------------------------------
@@ -81,8 +81,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Deallocate_Data
- IF( ALLOCATED( obj%val ) ) DEALLOCATE( obj%val )
- CALL setTotalDimension( obj, 0 )
+IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val)
+CALL setTotalDimension(obj, 0)
END PROCEDURE Deallocate_Data
!----------------------------------------------------------------------------
@@ -90,7 +90,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realmat_initiate1
- CALL Allocate( obj, Dims )
+CALL ALLOCATE (obj, Dims)
END PROCEDURE realmat_initiate1
!----------------------------------------------------------------------------
@@ -98,7 +98,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realmat_initiate2
- CALL Allocate( obj, [nrow, ncol] )
+CALL ALLOCATE (obj, [nrow, ncol])
END PROCEDURE realmat_initiate2
!----------------------------------------------------------------------------
@@ -106,10 +106,10 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realmat_initiate3
- INTEGER( I4B ) :: j
- DO j = 1, SIZE( obj )
- CALL Allocate( obj( j ), Dims )
- END DO
+INTEGER(I4B) :: j
+DO j = 1, SIZE(obj)
+ CALL ALLOCATE (obj(j), Dims)
+END DO
END PROCEDURE realmat_initiate3
!----------------------------------------------------------------------------
@@ -117,10 +117,10 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realmat_initiate4
- INTEGER( I4B ) :: j
- DO j = 1, SIZE( obj )
- CALL Allocate( obj( j ), Dims( j, : ) )
- END DO
+INTEGER(I4B) :: j
+DO j = 1, SIZE(obj)
+ CALL ALLOCATE (obj(j), Dims(j, :))
+END DO
END PROCEDURE realmat_initiate4
!----------------------------------------------------------------------------
@@ -128,8 +128,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realmat_initiate5
- obj%val = val
- CALL setTotalDimension( obj, 2_I4B )
+obj%val = val
+CALL setTotalDimension(obj, 2_I4B)
END PROCEDURE realmat_initiate5
!----------------------------------------------------------------------------
@@ -137,7 +137,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Constructor1
- CALL Initiate( obj, Dims )
+CALL Initiate(obj, Dims)
END PROCEDURE Constructor1
!----------------------------------------------------------------------------
@@ -145,11 +145,11 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realMat_eye1
- INTEGER( I4B ) :: i
- CALL Initiate( Ans, [m,m] )
- DO i = 1, m
- Ans%val ( i, i ) = 1.0
- END DO
+INTEGER(I4B) :: i
+CALL Initiate(Ans, [m, m])
+DO i = 1, m
+ Ans%val(i, i) = 1.0
+END DO
END PROCEDURE realMat_eye1
!----------------------------------------------------------------------------
@@ -157,8 +157,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE realmat_convert_1
- CALL Convert( From=From%val, To=To%val, Conversion=Conversion, nns=nns, &
- & tdof=tdof )
+CALL Convert(From=From%val, To=To%val, Conversion=Conversion, nns=nns, &
+ & tdof=tdof)
END PROCEDURE realmat_convert_1
!----------------------------------------------------------------------------
@@ -166,7 +166,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE sym_array
- Ans = 0.5_DFP * ( obj + TRANSPOSE( obj ) )
+Ans = 0.5_DFP * (obj + TRANSPOSE(obj))
END PROCEDURE sym_array
!----------------------------------------------------------------------------
@@ -174,7 +174,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE sym_obj
- Ans%val = 0.5_DFP * ( obj%val + TRANSPOSE( obj%val ) )
+Ans%val = 0.5_DFP * (obj%val + TRANSPOSE(obj%val))
END PROCEDURE sym_obj
!----------------------------------------------------------------------------
@@ -182,7 +182,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE SkewSym_array
- Ans = 0.5_DFP * ( obj - TRANSPOSE( obj ) )
+Ans = 0.5_DFP * (obj - TRANSPOSE(obj))
END PROCEDURE SkewSym_array
!----------------------------------------------------------------------------
@@ -190,87 +190,119 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE SkewSym_obj
- Ans%val = 0.5_DFP * ( obj%val - TRANSPOSE( obj%val ) )
+Ans%val = 0.5_DFP * (obj%val - TRANSPOSE(obj%val))
END PROCEDURE SkewSym_obj
!----------------------------------------------------------------------------
! MakeDiagonalCopies
!----------------------------------------------------------------------------
-MODULE PROCEDURE realmat_make_diag_copy1
- INTEGER( I4B ) :: I, s( 2 )
- REAL( DFP ), ALLOCATABLE :: DummyMat2( :, : )
-
- IF( ALLOCATED( mat ) ) THEN
- s = SHAPE( mat )
- DummyMat2 = mat
- CALL Reallocate( mat, s( 1 )*nCopy, s( 2 )*nCopy )
- DO I = 1, nCopy
- mat( ( I - 1 ) * s( 1 ) + 1 : I * s( 1 ), &
- & ( I - 1 ) * s( 2 ) + 1 : I * s( 2 ) ) &
- & = DummyMat2( :, : )
- END DO
- DEALLOCATE( DummyMat2 )
- END IF
-END PROCEDURE realmat_make_diag_copy1
+MODULE PROCEDURE MakeDiagonalCopies1
+INTEGER(I4B) :: I, s(2)
+REAL(DFP), ALLOCATABLE :: DummyMat2(:, :)
+
+IF (ALLOCATED(mat)) THEN
+ s = SHAPE(mat)
+ DummyMat2 = mat
+ CALL Reallocate(mat, s(1) * nCopy, s(2) * nCopy)
+ DO I = 1, nCopy
+ mat((I - 1) * s(1) + 1:I * s(1), &
+ & (I - 1) * s(2) + 1:I * s(2)) &
+ & = DummyMat2(:, :)
+ END DO
+ DEALLOCATE (DummyMat2)
+END IF
+END PROCEDURE MakeDiagonalCopies1
!----------------------------------------------------------------------------
-! MakeDiagonalCopies
+! MakeDiaginalCopies
!----------------------------------------------------------------------------
-MODULE PROCEDURE realmat_make_diag_copy2
- INTEGER( I4B ) :: I, S( 2 )
- S = SHAPE( From )
- CALL Reallocate( To, S( 1 )*nCopy, S( 2 )*nCopy )
- To = 0.0_DFP
- DO I = 1, nCopy
- To( ( I - 1 ) * S( 1 ) + 1 : I * S( 1 ), &
- & ( I - 1 ) * S( 2 ) + 1 : I * S( 2 ) ) &
- & = From( :, : )
+MODULE PROCEDURE MakeDiagonalCopies1_
+INTEGER(I4B) :: ii, jj, kk
+
+DO ii = 2, ncopy
+ DO CONCURRENT(jj=1:nrow, kk=1:ncol)
+ mat((ii - 1) * nrow + jj, (ii - 1) * ncol + kk) = mat(jj, kk)
END DO
-END PROCEDURE realmat_make_diag_copy2
+END DO
+
+END PROCEDURE MakeDiagonalCopies1_
!----------------------------------------------------------------------------
! MakeDiagonalCopies
!----------------------------------------------------------------------------
-MODULE PROCEDURE realmat_make_diag_copy3
- CALL realmat_make_diag_copy1( Mat = Mat%val, nCopy = nCopy )
-END PROCEDURE realmat_make_diag_copy3
+MODULE PROCEDURE MakeDiagonalCopies2
+INTEGER(I4B) :: I, S(2)
+S = SHAPE(From)
+CALL Reallocate(To, S(1) * nCopy, S(2) * nCopy)
+To = 0.0_DFP
+DO I = 1, nCopy
+ To((I - 1) * S(1) + 1:I * S(1), &
+ & (I - 1) * S(2) + 1:I * S(2)) &
+ & = From(:, :)
+END DO
+END PROCEDURE MakeDiagonalCopies2
!----------------------------------------------------------------------------
! MakeDiagonalCopies
!----------------------------------------------------------------------------
-MODULE PROCEDURE realmat_make_diag_copy4
- CALL realmat_make_diag_copy2( From = From%val, To = To%val, &
- & nCopy = nCopy )
-END PROCEDURE realmat_make_diag_copy4
+MODULE PROCEDURE MakeDiagonalCopies2_
+INTEGER(I4B) :: ii, jj, kk, nrow, ncol
+
+nrow = SIZE(from, 1)
+ncol = SIZE(from, 2)
+
+DO ii = 1, ncopy
+ DO CONCURRENT(jj=1:nrow, kk=1:ncol)
+ to((ii - 1) * nrow + jj, (ii - 1) * ncol + kk) = from(jj, kk)
+ END DO
+END DO
+END PROCEDURE MakeDiagonalCopies2_
!----------------------------------------------------------------------------
-! Random_Number
+! MakeDiagonalCopies
!----------------------------------------------------------------------------
-MODULE PROCEDURE realmat_random_number
- IF( PRESENT( m ) .AND. PRESENT( n ) ) THEN
- CALL Reallocate( obj%val, m, n )
- CALL RANDOM_NUMBER( obj%val )
- RETURN
- END IF
+MODULE PROCEDURE MakeDiagonalCopies3
+CALL MakeDiagonalCopies(Mat=Mat%val, nCopy=nCopy)
+END PROCEDURE MakeDiagonalCopies3
- IF( PRESENT( m ) ) THEN
- CALL Reallocate( obj%val, m, m )
- CALL RANDOM_NUMBER( obj%val )
- RETURN
- END IF
+!----------------------------------------------------------------------------
+! MakeDiagonalCopies
+!----------------------------------------------------------------------------
- IF( PRESENT( n ) ) THEN
- CALL Reallocate( obj%val, n, n )
- CALL RANDOM_NUMBER( obj%val )
- RETURN
- END IF
+MODULE PROCEDURE MakeDiagonalCopies4
+CALL MakeDiagonalCopies(From=From%val, To=To%val, &
+ nCopy=nCopy)
+END PROCEDURE MakeDiagonalCopies4
- CALL RANDOM_NUMBER( obj%val )
+!----------------------------------------------------------------------------
+! Random_Number
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE realmat_random_number
+IF (PRESENT(m) .AND. PRESENT(n)) THEN
+ CALL Reallocate(obj%val, m, n)
+ CALL RANDOM_NUMBER(obj%val)
+ RETURN
+END IF
+
+IF (PRESENT(m)) THEN
+ CALL Reallocate(obj%val, m, m)
+ CALL RANDOM_NUMBER(obj%val)
+ RETURN
+END IF
+
+IF (PRESENT(n)) THEN
+ CALL Reallocate(obj%val, n, n)
+ CALL RANDOM_NUMBER(obj%val)
+ RETURN
+END IF
+
+CALL RANDOM_NUMBER(obj%val)
END PROCEDURE realmat_random_number
@@ -279,14 +311,14 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE TestMatrix
- SELECT CASE( matNo )
- CASE( 1 )
- ALLOCATE( Ans( 4, 4 ) )
- Ans( :, 1 ) = [3.0, -3.0, 6.0, -9.0]
- Ans( :, 2 ) = [-7.0, 5.0, -4.0, 5.0]
- Ans( :, 3 ) = [-2.0, 1.0, 0.0, -5.0]
- Ans( :, 4 ) = [2.0, 0.0, -5.0, 12.0]
- END SELECT
+SELECT CASE (matNo)
+CASE (1)
+ ALLOCATE (Ans(4, 4))
+ Ans(:, 1) = [3.0, -3.0, 6.0, -9.0]
+ Ans(:, 2) = [-7.0, 5.0, -4.0, 5.0]
+ Ans(:, 3) = [-2.0, 1.0, 0.0, -5.0]
+ Ans(:, 4) = [2.0, 0.0, -5.0, 12.0]
+END SELECT
END PROCEDURE TestMatrix
!----------------------------------------------------------------------------
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc
index afe947737..1b76e4d6d 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc
@@ -50,7 +50,7 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -81,7 +81,7 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -150,7 +150,7 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -180,7 +180,7 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc
index 6e5dfa2e7..dfe461067 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_13.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_13.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_13a(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -109,7 +109,7 @@ PURE SUBROUTINE STCM_13b(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -173,7 +173,7 @@ PURE SUBROUTINE STCM_13c(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -237,7 +237,7 @@ PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_14.inc b/src/submodules/STConvectiveMatrix/src/STCM_14.inc
index 20a7621fe..8e7a0fae7 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_14.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_14.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_14a(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -109,7 +109,7 @@ PURE SUBROUTINE STCM_14b(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -173,7 +173,7 @@ PURE SUBROUTINE STCM_14c(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -237,7 +237,7 @@ PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_15.inc b/src/submodules/STConvectiveMatrix/src/STCM_15.inc
index 6b86dda81..07bc3e9c8 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_15.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_15.inc
@@ -50,7 +50,7 @@ PURE SUBROUTINE STCM_15a(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -119,7 +119,7 @@ PURE SUBROUTINE STCM_15b(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -188,7 +188,7 @@ PURE SUBROUTINE STCM_15c(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -257,7 +257,7 @@ PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_16.inc b/src/submodules/STConvectiveMatrix/src/STCM_16.inc
index 06ac2870a..42d6fde39 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_16.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_16.inc
@@ -50,7 +50,7 @@ PURE SUBROUTINE STCM_16a(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -119,7 +119,7 @@ PURE SUBROUTINE STCM_16b(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -188,7 +188,7 @@ PURE SUBROUTINE STCM_16c(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -257,7 +257,7 @@ PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_17.inc b/src/submodules/STConvectiveMatrix/src/STCM_17.inc
index 3f52946a9..091bf4901 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc
@@ -53,7 +53,7 @@ PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -127,7 +127,7 @@ PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -201,7 +201,7 @@ PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & SIZE(vbar, 1), trial(1)%refelem%nsd, &
+ & SIZE(vbar, 1), trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -274,7 +274,7 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, SIZE(vbar, 1), &
+ & trial(1)%nsd, SIZE(vbar, 1), &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_3.inc b/src/submodules/STConvectiveMatrix/src/STCM_3.inc
index 7ff2ee6e7..dbaf727b9 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_3.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_3.inc
@@ -56,7 +56,7 @@ PURE SUBROUTINE STCM_3a(ans, test, trial, term1, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -91,7 +91,7 @@ PURE SUBROUTINE STCM_3a(ans, test, trial, term1, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -167,7 +167,7 @@ PURE SUBROUTINE STCM_3b(ans, test, trial, term1, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -198,7 +198,7 @@ PURE SUBROUTINE STCM_3b(ans, test, trial, term1, &
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_5.inc b/src/submodules/STConvectiveMatrix/src/STCM_5.inc
index 6eb81e2d8..0e0019c5c 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_5.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_5.inc
@@ -56,7 +56,7 @@ PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -85,7 +85,7 @@ PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -156,7 +156,7 @@ PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -184,7 +184,7 @@ PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_7.inc b/src/submodules/STConvectiveMatrix/src/STCM_7.inc
index ac7faec21..949ebea9b 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_7.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_7.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -75,7 +75,7 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -137,7 +137,7 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, 1, &
+ & trial(1)%nsd, 1, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
@@ -167,7 +167,7 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & 1, trial(1)%refelem%nsd, &
+ & 1, trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90
index 03386ddca..de726de3e 100644
--- a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90
+++ b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90
@@ -46,14 +46,14 @@ PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, &
- & trial(1)%refelem%nsd, &
+ & trial(1)%nsd, &
+ & trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
CALL getInterpolation(obj=trial, interpol=kbar, val=k)
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -112,14 +112,14 @@ PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, &
- & trial(1)%refelem%nsd, &
+ & trial(1)%nsd, &
+ & trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
CALL getInterpolation(obj=trial, interpol=kbar, val=k)
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -195,7 +195,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -210,7 +210,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt)
DO b = 1, SIZE(IJab, 4)
DO a = 1, SIZE(IJab, 3)
!!
- IJab(:,:,a,b) = IJab(:,:,a,b) &
+ IJab(:, :, a, b) = IJab(:, :, a, b) &
& + OUTERPROD( &
& test(ipt)%dNTdXt(:, a, ii, ips), &
& trial(ipt)%dNTdXt(:, b, ii, ips))
@@ -220,15 +220,15 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt)
END DO
!!
DO ii = 1, SIZE(m6, 3)
- m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) &
- & + realval( ips ) * vbar(ii, ips, ipt) &
+ m6(:, :, ii, 1, :, :) = m6(:, :, ii, 1, :, :) &
+ & + realval(ips) * vbar(ii, ips, ipt) &
& * IJab
END DO
!!
END DO
END DO
!!
- CALL Convert( from=m6, to=ans)
+ CALL Convert(from=m6, to=ans)
!!
DEALLOCATE (realval, IJab, vbar, m6)
!!
@@ -277,7 +277,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -292,7 +292,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
DO b = 1, SIZE(IJab, 4)
DO a = 1, SIZE(IJab, 3)
!!
- IJab(:,:,a,b) = IJab(:,:,a,b) &
+ IJab(:, :, a, b) = IJab(:, :, a, b) &
& + OUTERPROD( &
& test(ipt)%dNTdXt(:, a, ii, ips), &
& trial(ipt)%dNTdXt(:, b, ii, ips))
@@ -302,8 +302,8 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
END DO
!!
DO ii = 1, SIZE(m6, 4)
- m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) &
- & + realval( ips ) * vbar(ii, ips, ipt) &
+ m6(:, :, 1, ii, :, :) = m6(:, :, 1, ii, :, :) &
+ & + realval(ips) * vbar(ii, ips, ipt) &
& * IJab
END DO
!!
@@ -311,7 +311,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
!!
END DO
!!
- CALL Convert( from=m6, to=ans)
+ CALL Convert(from=m6, to=ans)
!!
DEALLOCATE (realval, IJab, vbar, m6)
!!
@@ -346,15 +346,15 @@ PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, &
- & trial(1)%refelem%nsd, &
+ & trial(1)%nsd, &
+ & trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -416,20 +416,20 @@ PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt)
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
& SIZE(trial(1)%N, 1), &
- & trial(1)%refelem%nsd, &
- & trial(1)%refelem%nsd, &
+ & trial(1)%nsd, &
+ & trial(1)%nsd, &
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:,ipt)
+ & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt) * c2bar(:, ipt)
!!
DO ips = 1, SIZE(realval)
!!
@@ -504,7 +504,7 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -519,7 +519,7 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt)
DO b = 1, SIZE(IJab, 4)
DO a = 1, SIZE(IJab, 3)
!!
- IJab(:,:,a,b) = IJab(:,:,a,b) &
+ IJab(:, :, a, b) = IJab(:, :, a, b) &
& + OUTERPROD( &
& test(ipt)%dNTdXt(:, a, ii, ips), &
& trial(ipt)%dNTdXt(:, b, ii, ips))
@@ -529,15 +529,15 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt)
END DO
!!
DO ii = 1, SIZE(m6, 3)
- m6(:,:,ii,1,:,:) = m6(:,:,ii,1,:,:) &
- & + realval( ips ) * vbar(ii, ips, ipt) &
+ m6(:, :, ii, 1, :, :) = m6(:, :, ii, 1, :, :) &
+ & + realval(ips) * vbar(ii, ips, ipt) &
& * IJab
END DO
!!
END DO
END DO
!!
- CALL Convert( from=m6, to=ans)
+ CALL Convert(from=m6, to=ans)
!!
DEALLOCATE (realval, IJab, vbar, m6, cbar)
!!
@@ -590,12 +590,12 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt * cbar(:,ipt)
+ & * trial(ipt)%wt * trial(ipt)%jt * cbar(:, ipt)
!!
DO ips = 1, SIZE(realval)
!!
@@ -605,7 +605,7 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt)
DO b = 1, SIZE(IJab, 4)
DO a = 1, SIZE(IJab, 3)
!!
- IJab(:,:,a,b) = IJab(:,:,a,b) &
+ IJab(:, :, a, b) = IJab(:, :, a, b) &
& + OUTERPROD( &
& test(ipt)%dNTdXt(:, a, ii, ips), &
& trial(ipt)%dNTdXt(:, b, ii, ips))
@@ -615,8 +615,8 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt)
END DO
!!
DO ii = 1, SIZE(m6, 4)
- m6(:,:,1,ii,:,:) = m6(:,:,1,ii,:,:) &
- & + realval( ips ) * vbar(ii, ips, ipt) &
+ m6(:, :, 1, ii, :, :) = m6(:, :, 1, ii, :, :) &
+ & + realval(ips) * vbar(ii, ips, ipt) &
& * IJab
END DO
!!
@@ -624,7 +624,7 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt)
!!
END DO
!!
- CALL Convert( from=m6, to=ans)
+ CALL Convert(from=m6, to=ans)
!!
DEALLOCATE (realval, IJab, vbar, m6)
!!
@@ -672,7 +672,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!!
CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
& SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
-nsd = trial(1)%refelem%nsd
+nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness &
@@ -688,7 +688,7 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!!
CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
!!
-if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
DEALLOCATE (realval, iajb)
END PROCEDURE mat4_STDiffusionMatrix_1
@@ -698,42 +698,42 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!----------------------------------------------------------------------------
MODULE PROCEDURE mat4_STDiffusionMatrix_2
- ! CALL STDM_1(ans=ans, test=test, trial=trial, k=k, opt=opt)
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: kbar(:, :)
- INTEGER(I4B) :: ips, ipt, ii, nsd
+! CALL STDM_1(ans=ans, test=test, trial=trial, k=k, opt=opt)
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: kbar(:, :)
+INTEGER(I4B) :: ips, ipt, ii, nsd
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=k)
+CALL getInterpolation(obj=trial, interpol=kbar, val=k)
!!
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
!!
- nsd = trial(1)%refelem%nsd
+nsd = trial(1)%nsd
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt)
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt * kbar(:, ipt)
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- iajb = iajb + realval(ips) &
- & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),&
- & trial(ipt)%dNTdXt(:, :, ii, ips))
+ iajb = iajb + realval(ips) &
+ & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),&
+ & trial(ipt)%dNTdXt(:, :, ii, ips))
!!
- END DO
END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, iajb, kbar)
+DEALLOCATE (realval, iajb, kbar)
END PROCEDURE mat4_STDiffusionMatrix_2
!----------------------------------------------------------------------------
@@ -741,39 +741,39 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!----------------------------------------------------------------------------
MODULE PROCEDURE mat4_STDiffusionMatrix_3
- ! CALL STDM_2(ans=ans, test=test, trial=trial, k=k, opt=opt)
+! CALL STDM_2(ans=ans, test=test, trial=trial, k=k, opt=opt)
!! Internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: p1(:, :, :)
- REAL(DFP), ALLOCATABLE :: p2(:, :, :)
- INTEGER(I4B) :: ips, ipt
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: p1(:, :, :)
+REAL(DFP), ALLOCATABLE :: p2(:, :, :)
+INTEGER(I4B) :: ips, ipt
!!
!! main
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
!!
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=k)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k)
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips))
+ iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips))
!!
- END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, iajb, p1, p2)
+DEALLOCATE (realval, iajb, p1, p2)
END PROCEDURE mat4_STDiffusionMatrix_3
!----------------------------------------------------------------------------
@@ -781,44 +781,44 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!----------------------------------------------------------------------------
MODULE PROCEDURE mat4_STDiffusionMatrix_4
- ! CALL STDM_3(ans=ans, test=test, trial=trial, k=k, opt=opt)
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt, ii, jj, nsd
+! CALL STDM_3(ans=ans, test=test, trial=trial, k=k, opt=opt)
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: IaJb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :)
+INTEGER(I4B) :: ips, ipt, ii, jj, nsd
!!
!! main
- CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL Reallocate(IaJb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=k)
+CALL getInterpolation(obj=trial, interpol=kbar, val=k)
!!
- nsd = trial(1)%refelem%nsd
+nsd = trial(1)%nsd
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * &
- & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), &
- & trial(ipt)%dNTdXt(:, :, jj, ips))
+ IaJb = IaJb + realval(ips) * kbar(ii, jj, ips, ipt) * &
+ & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), &
+ & trial(ipt)%dNTdXt(:, :, jj, ips))
!!
- END DO
END DO
END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=IaJb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, KBar, IaJb)
+DEALLOCATE (realval, KBar, IaJb)
END PROCEDURE mat4_STDiffusionMatrix_4
!----------------------------------------------------------------------------
@@ -830,48 +830,48 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! scalar
!! scalar
!!
- ! CALL STDM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
+! CALL STDM_6(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
!!
!!
!! Internal variable
!!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :)
- INTEGER(I4B) :: ips, ipt, ii, nsd
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: c1bar(:, :)
+REAL(DFP), ALLOCATABLE :: c2bar(:, :)
+INTEGER(I4B) :: ips, ipt, ii, nsd
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
+CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
+CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
!!
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
!!
- nsd = trial(1)%refelem%nsd
+nsd = trial(1)%nsd
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness &
- & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt)
+ realval = trial(ipt)%Js * trial(ipt)%Ws * trial(ipt)%Thickness &
+ & * trial(ipt)%Wt * trial(ipt)%Jt * c1bar(:, ipt) * c2bar(:, ipt)
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- iajb = iajb + realval(ips) &
- & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),&
- & trial(ipt)%dNTdXt(:, :, ii, ips))
+ iajb = iajb + realval(ips) &
+ & * OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips),&
+ & trial(ipt)%dNTdXt(:, :, ii, ips))
!!
- END DO
END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, iajb, c1bar, c2bar)
+DEALLOCATE (realval, iajb, c1bar, c2bar)
END PROCEDURE mat4_STDiffusionMatrix_5
!----------------------------------------------------------------------------
@@ -883,40 +883,40 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! scalar
!! vector
!!
- ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
+! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
!!
!! Internal variable
!!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:,:)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: p1(:, :, :)
- REAL(DFP), ALLOCATABLE :: p2(:, :, :)
- INTEGER(I4B) :: ips, ipt
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: c1bar(:, :)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: p1(:, :, :)
+REAL(DFP), ALLOCATABLE :: p2(:, :, :)
+INTEGER(I4B) :: ips, ipt
!!
!! main
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:,ipt)
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2)
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2)
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt * c1bar(:, ipt)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c2)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2)
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips))
+ iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips))
!!
- END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, c1bar, iajb, p1, p2)
+DEALLOCATE (realval, c1bar, iajb, p1, p2)
!!
END PROCEDURE mat4_STDiffusionMatrix_6
@@ -929,49 +929,49 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! scalar
!! matrix
!!
- ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
+! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
!!
!! Internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: rhobar(:, :)
- REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt, ii, jj, nsd
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: rhobar(:, :)
+REAL(DFP), ALLOCATABLE :: kbar(:, :, :, :)
+INTEGER(I4B) :: ips, ipt, ii, jj, nsd
!!
!! main
!!
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=rhobar, val=c1)
- CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+CALL getInterpolation(obj=trial, interpol=rhobar, val=c1)
+CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
!!
- nsd = trial(1)%refelem%nsd
+nsd = trial(1)%nsd
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * &
- & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), &
- & trial(ipt)%dNTdXt(:, :, jj, ips))
+ iajb = iajb + realval(ips) * kbar(ii, jj, ips, ipt) * &
+ & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), &
+ & trial(ipt)%dNTdXt(:, :, jj, ips))
!!
- END DO
END DO
END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, iajb, rhobar, kbar)
+DEALLOCATE (realval, iajb, rhobar, kbar)
END PROCEDURE mat4_STDiffusionMatrix_7
!----------------------------------------------------------------------------
@@ -983,10 +983,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! vector
!! scalar
!!
- ! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt)
+! CALL STDM_7(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt)
!!
- ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, &
- & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableVector, opt=opt )
+ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, &
+ & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableVector, opt=opt)
END PROCEDURE mat4_STDiffusionMatrix_8
!----------------------------------------------------------------------------
@@ -998,38 +998,38 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! vector
!! vector
!!
- ! CALL STDM_4(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
+! CALL STDM_4(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
!!
!! Internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: p1(:, :, :)
- REAL(DFP), ALLOCATABLE :: p2(:, :, :)
- INTEGER(I4B) :: ips, ipt
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: p1(:, :, :)
+REAL(DFP), ALLOCATABLE :: p2(:, :, :)
+INTEGER(I4B) :: ips, ipt
!!
!! main
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
!!
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1)
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2)
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p1, val=c1)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=c2)
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips))
+ iajb = iajb + realval(ips) * OUTERPROD(p1(:, :, ips), p2(:, :, ips))
!!
- END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, iajb, p1, p2)
+DEALLOCATE (realval, iajb, p1, p2)
END PROCEDURE mat4_STDiffusionMatrix_9
!----------------------------------------------------------------------------
@@ -1054,10 +1054,10 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! matrix
!! scalar
!!
- ! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt)
+! CALL STDM_5(ans=ans, test=test, trial=trial, c1=c2, c2=c1, opt=opt)
!!
- ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, &
- & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableMatrix, opt=opt)
+ans = STDiffusionMatrix(test=test, trial=trial, c1=c2, c2=c1, &
+ & c1rank=TypeFEVariableScalar, c2rank=TypeFEVariableMatrix, opt=opt)
!!
END PROCEDURE mat4_STDiffusionMatrix_11
@@ -1083,49 +1083,49 @@ END SUBROUTINE MakeDiagonalCopiesIJab
!! matrix
!! matrix
!!
- ! CALL STDM_8(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
+! CALL STDM_8(ans=ans, test=test, trial=trial, c1=c1, c2=c2, opt=opt)
!!
!! Internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :)
- REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt, ii, jj, nsd
+REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP), ALLOCATABLE :: m2(:, :)
+REAL(DFP), ALLOCATABLE :: iajb(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: k1bar(:, :, :, :)
+REAL(DFP), ALLOCATABLE :: k2bar(:, :, :, :)
+INTEGER(I4B) :: ips, ipt, ii, jj, nsd
!!
!! main
- CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
- & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
- CALL getInterpolation(obj=trial, interpol=k1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=k2bar, val=c2)
- nsd = trial(1)%refelem%nsd
+CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
+ & SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
+CALL getInterpolation(obj=trial, interpol=k1bar, val=c1)
+CALL getInterpolation(obj=trial, interpol=k2bar, val=c2)
+nsd = trial(1)%nsd
!!
- DO ipt = 1, SIZE(trial)
+DO ipt = 1, SIZE(trial)
!!
- realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
- & * trial(ipt)%wt * trial(ipt)%jt
+ realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness &
+ & * trial(ipt)%wt * trial(ipt)%jt
!!
- DO ips = 1, SIZE(realval)
+ DO ips = 1, SIZE(realval)
!!
- m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt))
+ m2 = MATMUL(k1bar(:, :, ips, ipt), k2bar(:, :, ips, ipt))
!!
- DO jj = 1, nsd
+ DO jj = 1, nsd
!!
- DO ii = 1, nsd
+ DO ii = 1, nsd
!!
- iajb = iajb + realval(ips) * m2(ii, jj) * &
- & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), &
- & trial(ipt)%dNTdXt(:, :, jj, ips))
+ iajb = iajb + realval(ips) * m2(ii, jj) * &
+ & OUTERPROD(test(ipt)%dNTdXt(:, :, ii, ips), &
+ & trial(ipt)%dNTdXt(:, :, jj, ips))
!!
- END DO
END DO
END DO
END DO
+END DO
!!
- CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
- if(present(opt)) call MakeDiagonalCopiesIJab(ans, opt)
+CALL SWAP(a=ans, b=iajb, i1=1, i2=3, i3=2, i4=4)
+IF (PRESENT(opt)) CALL MakeDiagonalCopiesIJab(ans, opt)
!!
- DEALLOCATE (realval, m2, iajb, k1bar, k2bar)
+DEALLOCATE (realval, m2, iajb, k1bar, k2bar)
!!
END PROCEDURE mat4_STDiffusionMatrix_13
diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90
index 11e983a30..65c2c2283 100644
--- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90
+++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90
@@ -83,6 +83,68 @@
END PROCEDURE obj_StiffnessMatrix1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_StiffnessMatrix1_
+REAL(DFP) :: Cbar(test%nsd * (test%nsd + 1) / 2, &
+ trial%nsd * (trial%nsd + 1) / 2, &
+ trial%nips), &
+ Ce(test%nsd * test%nsd, trial%nsd * trial%nsd), &
+ BMat1(test%nsd * test%nns, trial%nsd * trial%nsd), &
+ BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd)
+INTEGER(I4B) :: nips, nns1, nns2, ips, nsd, ii, jj, kk
+INTEGER(I4B) :: indx(3, 3)
+REAL(DFP) :: realval
+
+nns1 = test%nns
+nns2 = trial%nns
+nips = trial%nips
+nsd = trial%nsd
+nrow = nns1 * nsd
+ncol = nns2 * nsd
+ans(1:nrow, 1:ncol) = 0.0
+
+CALL GetInterpolation_(obj=test, interpol=CBar, val=Cijkl, &
+ dim1=ii, dim2=jj, dim3=kk)
+
+SELECT CASE (nsd)
+CASE (1)
+ indx(1, 1) = 1
+CASE (2)
+ indx(1:2, 1:2) = RESHAPE([1, 3, 3, 2], [2, 2])
+CASE (3)
+ indx(1:3, 1:3) = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3])
+END SELECT
+
+BMat1 = 0.0_DFP
+BMat2 = 0.0_DFP
+
+DO ips = 1, nips
+ realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips)
+
+ DO jj = 1, nsd
+ DO ii = 1, nsd
+ Ce((ii - 1) * nsd + 1:ii * nsd, (jj - 1) * nsd + 1:jj * nsd) &
+ & = CBar(indx(1:nsd, ii), indx(1:nsd, jj), ips)
+ END DO
+ END DO
+
+ DO ii = 1, nsd
+ BMat1((ii - 1) * nns1 + 1:ii * nns1, (ii - 1) * nsd + 1:ii * nsd) = &
+ & test%dNdXt(1:nns1, 1:nsd, ips)
+ BMat2((ii - 1) * nns2 + 1:ii * nns2, (ii - 1) * nsd + 1:ii * nsd) = &
+ & trial%dNdXt(1:nns2, 1:nsd, ips)
+ END DO
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2))
+
+END DO
+
+END PROCEDURE obj_StiffnessMatrix1_
+
!----------------------------------------------------------------------------
! StiffnessMatrix
!----------------------------------------------------------------------------
@@ -163,6 +225,83 @@
END PROCEDURE obj_StiffnessMatrix2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_StiffnessMatrix2_
+REAL(DFP) :: lambdaBar(trial%nips), muBar(trial%nips), &
+ Ke11(test%nns, trial%nns)
+REAL(DFP) :: realval
+REAL(DFP) :: real1, real2, real3
+INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, ii, jj, &
+ r1, r2, ips, kk, ll
+LOGICAL(LGT) :: abool
+TYPE(FEVariable_) :: lambda0
+REAL(DFP), PARAMETER :: one = 1.0_DFP, zero = 0.0_DFP
+
+abool = Input(default=.FALSE., option=isLambdaYoungsModulus)
+IF (abool) THEN
+ CALL GetLambdaFromYoungsModulus(lambda=lambda0, &
+ & youngsModulus=lambda, shearModulus=mu)
+ELSE
+ lambda0 = lambda
+END IF
+
+nns1 = test%nns
+nns2 = trial%nns
+nips = trial%nips
+nsd = trial%nsd
+nrow = nns1 * nsd
+ncol = nns2 * nsd
+ans(1:nrow, 1:ncol) = zero
+
+CALL GetInterpolation_(obj=test, interpol=lambdaBar, val=lambda0, tsize=ii)
+CALL GetInterpolation_(obj=test, interpol=muBar, val=mu, tsize=ii)
+
+DO ips = 1, nips
+
+ realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips)
+ real1 = muBar(ips) * realval
+ real2 = (lambdaBar(ips) + muBar(ips)) * realval
+ real3 = lambdaBar(ips) * realval
+ c1 = 0
+ c2 = 0
+
+ DO jj = 1, nsd
+ c1 = c2 + 1
+ c2 = jj * nns2
+ r1 = 0
+ r2 = 0
+ DO ii = 1, nsd
+ r1 = r2 + 1
+ r2 = ii * nns1
+ IF (ii .EQ. jj) THEN
+ Ke11(1:nns1, 1:nns2) = real1 * MATMUL(test%dNdXt(:, :, ips), &
+ & TRANSPOSE(trial%dNdXt(:, :, ips)))
+ CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), &
+ b=trial%dNdXt(1:nns2, ii, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real2, anscoeff=one)
+ ELSE
+ CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), &
+ b=trial%dNdXt(1:nns2, jj, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real3, anscoeff=zero)
+ CALL OuterProd_(a=test%dNdXt(1:nns1, jj, ips), &
+ b=trial%dNdXt(1:nns2, ii, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real1, anscoeff=one)
+ END IF
+ ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11
+ END DO
+ END DO
+END DO
+
+CALL DEALLOCATE (lambda0)
+
+END PROCEDURE obj_StiffnessMatrix2_
+
!----------------------------------------------------------------------------
! Stiffnessmatrix
!----------------------------------------------------------------------------
@@ -213,6 +352,59 @@
!
!----------------------------------------------------------------------------
+MODULE PROCEDURE obj_StiffnessMatrix3_
+INTEGER(I4B) :: nns1, nns2, nips, ips, nsd, c1, c2, &
+ r1, r2, ii, jj, kk, ll
+REAL(DFP) :: realval, Ke11(test%nns, trial%nns)
+REAL(DFP) :: real1, real2, real3
+REAL(DFP), PARAMETER :: one = 1.0_DFP, zero = 0.0_DFP
+
+nns1 = test%nns
+nns2 = trial%nns
+nips = trial%nips
+nsd = trial%nsd
+nrow = nns1 * nsd
+ncol = nns2 * nsd
+ans(1:nrow, 1:ncol) = zero
+
+DO ips = 1, nips
+ realval = trial%ws(ips) * trial%thickness(ips) * trial%js(ips)
+ real1 = mu * realval
+ real2 = (lambda + mu) * realval
+ real3 = lambda * realval
+ c1 = 0; c2 = 0;
+ DO jj = 1, nsd
+ c1 = c2 + 1; c2 = jj * nns2; r1 = 0; r2 = 0
+ DO ii = 1, nsd
+ r1 = r2 + 1; r2 = ii * nns1
+ IF (ii .EQ. jj) THEN
+ Ke11 = real1 * MATMUL(test%dNdXt(:, :, ips), &
+ TRANSPOSE(trial%dNdXt(:, :, ips)))
+ CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), &
+ b=trial%dNdXt(1:nns2, ii, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real2, anscoeff=one)
+ ELSE
+ CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), &
+ b=trial%dNdXt(1:nns2, jj, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real3, anscoeff=zero)
+ CALL OuterProd_(a=test%dNdXt(1:nns1, jj, ips), &
+ b=trial%dNdXt(1:nns2, ii, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real1, anscoeff=one)
+ END IF
+ ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11(1:nns1, 1:nns2)
+ END DO
+ END DO
+END DO
+
+END PROCEDURE obj_StiffnessMatrix3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE obj_StiffnessMatrix4
REAL(DFP), ALLOCATABLE :: realval(:), Ce(:, :), BMat1(:, :), BMat2(:, :)
INTEGER(I4B) :: nips, nns1, nns2, i, j, ips, nsd
@@ -271,6 +463,62 @@
END PROCEDURE obj_StiffnessMatrix4
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_StiffnessMatrix4_
+REAL(DFP) :: realval
+REAL(DFP) :: Ce(test%nsd * test%nsd, trial%nsd * trial%nsd), &
+ BMat1(test%nsd * test%nns, test%nsd * test%nsd), &
+ BMat2(trial%nsd * trial%nns, trial%nsd * trial%nsd)
+INTEGER(I4B) :: nips, nns1, nns2, ii, jj, ips, nsd
+INTEGER(I4B), ALLOCATABLE :: indx(:, :)
+
+nns1 = SIZE(test%N, 1)
+nns2 = SIZE(trial%N, 1)
+nips = SIZE(trial%N, 2)
+nsd = SIZE(trial%dNdXt, 2)
+
+nrow = nns1 * nsd
+ncol = nns2 * nsd
+
+SELECT CASE (nsd)
+CASE (1)
+ indx(1, 1) = 1
+CASE (2)
+ indx(1:2, 1:2) = RESHAPE([1, 3, 3, 2], [2, 2])
+CASE (3)
+ indx(1:3, 1:3) = RESHAPE([1, 4, 6, 4, 2, 5, 6, 5, 3], [3, 3])
+END SELECT
+
+BMat1 = 0.0_DFP
+BMat2 = 0.0_DFP
+
+DO ips = 1, nips
+
+ realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips)
+ DO jj = 1, nsd
+ DO ii = 1, nsd
+ Ce((ii - 1) * nsd + 1:ii * nsd, (jj - 1) * nsd + 1:jj * nsd) &
+ & = Cijkl(indx(1:nsd, ii), indx(1:nsd, jj))
+ END DO
+ END DO
+
+ DO ii = 1, nsd
+ BMat1((ii - 1) * nns1 + 1:ii * nns1, (ii - 1) * nsd + 1:ii * nsd) = &
+ & test%dNdXt(:, :, ips)
+ BMat2((ii - 1) * nns2 + 1:ii * nns2, (ii - 1) * nsd + 1:ii * nsd) = &
+ & trial%dNdXt(:, :, ips)
+ END DO
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * MATMUL(MATMUL(BMat1, Ce), TRANSPOSE(BMat2))
+
+END DO
+
+END PROCEDURE obj_StiffnessMatrix4_
+
!----------------------------------------------------------------------------
! StiffnessMatrix
!----------------------------------------------------------------------------
@@ -335,4 +583,63 @@
!
!----------------------------------------------------------------------------
+MODULE PROCEDURE obj_StiffnessMatrix5_
+REAL(DFP) :: realval, Ke11(test%nns, trial%nns)
+REAL(DFP) :: real1, real2, real3
+INTEGER(I4B) :: nns1, nns2, nips, nsd, c1, c2, ii, jj, &
+ r1, r2, ips, kk, ll
+REAL(DFP), PARAMETER :: one = 1.0_DFP, zero = 0.0_DFP
+
+nns1 = SIZE(test%N, 1)
+nns2 = SIZE(trial%N, 1)
+nips = SIZE(trial%N, 2)
+nsd = SIZE(trial%dNdXt, 2)
+nrow = nns1 * nsd
+ncol = nns2 * nsd
+ans(1:nrow, 1:ncol) = zero
+
+DO ips = 1, nips
+ realval = trial%ws(ips) * trial%js(ips) * trial%thickness(ips)
+ real1 = mu(ips) * realval
+ real2 = (lambda(ips) + mu(ips)) * realval
+ real3 = lambda(ips) * realval
+ c1 = 0
+ c2 = 0
+ DO jj = 1, nsd
+ c1 = c2 + 1
+ c2 = jj * nns2
+ r1 = 0
+ r2 = 0
+ DO ii = 1, nsd
+ r1 = r2 + 1
+ r2 = ii * nns1
+ IF (ii .EQ. jj) THEN
+ Ke11 = real1 * MATMUL( &
+ test%dNdXt(:, :, ips), &
+ TRANSPOSE(trial%dNdXt(:, :, ips)))
+ CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), &
+ b=trial%dNdXt(1:nns2, ii, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real2, anscoeff=one)
+ ELSE
+ CALL OuterProd_(a=test%dNdXt(1:nns1, ii, ips), &
+ b=trial%dNdXt(1:nns2, jj, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real3, anscoeff=zero)
+ CALL OuterProd_(a=test%dNdXt(1:nns1, jj, ips), &
+ b=trial%dNdXt(1:nns2, ii, ips), &
+ nrow=kk, ncol=ll, ans=Ke11, &
+ scale=real1, anscoeff=one)
+ END IF
+ ans(r1:r2, c1:c2) = ans(r1:r2, c1:c2) + Ke11(1:nns1, 1:nns2)
+ END DO
+ END DO
+END DO
+
+END PROCEDURE obj_StiffnessMatrix5_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END SUBMODULE Methods
diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90
index 658b358e7..20e817b35 100644
--- a/src/submodules/Utility/src/ConvertUtility@Methods.F90
+++ b/src/submodules/Utility/src/ConvertUtility@Methods.F90
@@ -96,6 +96,35 @@
END DO
END PROCEDURE convert_2
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE convert2_
+INTEGER(I4B) :: a, b, r1, r2, c1, c2
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+
+dim1 = SIZE(From, 1)
+dim2 = SIZE(From, 2)
+dim3 = SIZE(From, 3)
+dim4 = SIZE(From, 4)
+nrow = dim1 * dim3
+ncol = dim2 * dim4
+c1 = 0; c2 = 0
+
+DO b = 1, dim4
+ c1 = c2 + 1
+ c2 = b * dim2
+ r1 = 0; r2 = 0
+ DO a = 1, dim3
+ r1 = r2 + 1;
+ r2 = a * dim1
+ To(r1:r2, c1:c2) = From(1:dim1, 1:dim2, a, b)
+ END DO
+END DO
+
+END PROCEDURE convert2_
+
!----------------------------------------------------------------------------
! Convert
!----------------------------------------------------------------------------
@@ -120,4 +149,32 @@
!
!----------------------------------------------------------------------------
+MODULE PROCEDURE convert3_
+INTEGER(I4B) :: a, b
+INTEGER(I4B) :: n1, n2, n3, n4, n5, n6
+
+n1 = SIZE(from, 1)
+n2 = SIZE(from, 2)
+n3 = SIZE(from, 3)
+n4 = SIZE(from, 4)
+n5 = SIZE(from, 5)
+n6 = SIZE(from, 6)
+
+dim3 = n5
+dim4 = n6
+
+DO b = 1, n6
+ DO a = 1, n5
+ CALL Convert_(from=from(1:n1, 1:n2, 1:n3, 1:n4, a, b), &
+ to=to(1:n1 * n3, 1:n2 * n4, a, b), &
+ nrow=dim1, ncol=dim2)
+ END DO
+END DO
+
+END PROCEDURE convert3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END SUBMODULE Methods
diff --git a/src/submodules/Utility/src/GridPointUtility@Methods.F90 b/src/submodules/Utility/src/GridPointUtility@Methods.F90
index a01b11291..d98d73f10 100644
--- a/src/submodules/Utility/src/GridPointUtility@Methods.F90
+++ b/src/submodules/Utility/src/GridPointUtility@Methods.F90
@@ -38,7 +38,7 @@
beta = LOG(a) / (N - 1)
alpha = (rmax - rmin) / (EXP(beta * N) - 1)
DO i = 1, N + 1
- ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin
+ ans(i) = alpha * (EXP(beta * (i - 1)) - 1) + rmin
END DO
ELSE IF (N .EQ. 1) THEN
ans(1) = rmin
@@ -54,19 +54,19 @@
MODULE PROCEDURE ExpMesh_Real32
INTEGER(I4B) :: i
-REAL(Real32) :: alpha, beta
+REAL(REAL32) :: alpha, beta
!!
IF (ABS(a - 1) .LT. TINY(1.0_DFP)) THEN
alpha = (rmax - rmin) / N
DO i = 1, N + 1
- ans(i) = alpha * (i - 1.0_Real32) + rmin
+ ans(i) = alpha * (i - 1.0_REAL32) + rmin
END DO
ELSE
IF (N .GT. 1) THEN
beta = LOG(a) / (N - 1)
alpha = (rmax - rmin) / (EXP(beta * N) - 1)
DO i = 1, N + 1
- ans(i) = alpha * (exp(beta * (i - 1)) - 1) + rmin
+ ans(i) = alpha * (EXP(beta * (i - 1)) - 1) + rmin
END DO
ELSE IF (N .EQ. 1) THEN
ans(1) = rmin
@@ -82,7 +82,7 @@
MODULE PROCEDURE LinSpace_Real32
! Local vars
-REAL(Real32) :: dx
+REAL(REAL32) :: dx
INTEGER(I4B) :: i
INTEGER(I4B) :: nn
!! main
@@ -91,7 +91,7 @@
ans = [a]
ELSE
ALLOCATE (ans(nn))
- dx = (b - a) / REAL((nn - 1), Real32)
+ dx = (b - a) / REAL((nn - 1), REAL32)
ans = [(i * dx + a, i=0, nn - 1)]
END IF
END PROCEDURE LinSpace_Real32
@@ -102,7 +102,7 @@
MODULE PROCEDURE LinSpace_Real64
! Local vars
-REAL(Real64) :: dx
+REAL(REAL64) :: dx
INTEGER(I4B) :: i
INTEGER(I4B) :: nn
!> main
@@ -111,7 +111,7 @@
ans = [a]
ELSE
ALLOCATE (ans(nn))
- dx = (b - a) / REAL((nn - 1), Real64)
+ dx = (b - a) / REAL((nn - 1), REAL64)
ans = [(i * dx + a, i=0, nn - 1)]
END IF
END PROCEDURE LinSpace_Real64
@@ -123,7 +123,7 @@
MODULE PROCEDURE LogSpace_Real32
INTEGER(I4B) :: base0, n0
LOGICAL(LGT) :: endpoint0
-REAL(Real32), ALLOCATABLE :: ans0(:)
+REAL(REAL32), ALLOCATABLE :: ans0(:)
!!
endpoint0 = INPUT(option=endPoint, default=.TRUE.)
base0 = INPUT(option=base, default=10)
@@ -147,7 +147,7 @@
MODULE PROCEDURE LogSpace_Real64
INTEGER(I4B) :: base0, n0
LOGICAL(LGT) :: endpoint0
-REAL(Real64), ALLOCATABLE :: ans0(:)
+REAL(REAL64), ALLOCATABLE :: ans0(:)
!!
endpoint0 = INPUT(option=endPoint, default=.TRUE.)
base0 = INPUT(option=base, default=10)
@@ -175,8 +175,8 @@
! Initial setting
nx = SIZE(xgv, dim=1)
ny = SIZE(ygv, dim=1)
-CALL Reallocate(x, ny, nx)
-CALL Reallocate(y, ny, nx)
+CALL Reallocate(x, nx, ny)
+CALL Reallocate(y, nx, ny)
x(:, :) = SPREAD(xgv, dim=2, ncopies=ny)
y(:, :) = SPREAD(ygv, dim=1, ncopies=nx)
END PROCEDURE MeshGrid2D_Real64
@@ -192,8 +192,8 @@
! Initial setting
nx = SIZE(xgv, dim=1)
ny = SIZE(ygv, dim=1)
-CALL Reallocate(x, ny, nx)
-CALL Reallocate(y, ny, nx)
+CALL Reallocate(x, nx, ny)
+CALL Reallocate(y, nx, ny)
x(:, :) = SPREAD(xgv, dim=2, ncopies=ny)
y(:, :) = SPREAD(ygv, dim=1, ncopies=nx)
END PROCEDURE MeshGrid2D_Real32
@@ -203,8 +203,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE MeshGrid3D_Real64
-integer :: nx, ny, nz, i
-nx = size(xgv); ny = size(ygv); nz = size(zgv)
+INTEGER :: nx, ny, nz, i
+nx = SIZE(xgv); ny = SIZE(ygv); nz = SIZE(zgv)
CALL Reallocate(x, nx, ny, nz)
CALL Reallocate(y, nx, ny, nz)
CALL Reallocate(z, nx, ny, nz)
@@ -222,8 +222,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE MeshGrid3D_Real32
-integer :: nx, ny, nz, i
-nx = size(xgv); ny = size(ygv); nz = size(zgv)
+INTEGER :: nx, ny, nz, i
+nx = SIZE(xgv); ny = SIZE(ygv); nz = SIZE(zgv)
CALL Reallocate(x, ny, nx, nz)
CALL Reallocate(y, ny, nx, nz)
CALL Reallocate(z, ny, nx, nz)
diff --git a/src/submodules/Utility/src/In/In_1.inc b/src/submodules/Utility/src/In/In_1.F90
similarity index 99%
rename from src/submodules/Utility/src/In/In_1.inc
rename to src/submodules/Utility/src/In/In_1.F90
index 1bbf7c7cf..66065b8a6 100644
--- a/src/submodules/Utility/src/In/In_1.inc
+++ b/src/submodules/Utility/src/In/In_1.F90
@@ -15,7 +15,6 @@
! along with this program. If not, see
!
-
INTEGER(I4B) :: ii
ans = .TRUE.
diff --git a/src/submodules/Utility/src/In/IsIn_1.inc b/src/submodules/Utility/src/In/IsIn_1.F90
similarity index 100%
rename from src/submodules/Utility/src/In/IsIn_1.inc
rename to src/submodules/Utility/src/In/IsIn_1.F90
diff --git a/src/submodules/Utility/src/IntegerUtility@Methods.F90 b/src/submodules/Utility/src/IntegerUtility@Methods.F90
index ae4879e44..295fd8e6e 100644
--- a/src/submodules/Utility/src/IntegerUtility@Methods.F90
+++ b/src/submodules/Utility/src/IntegerUtility@Methods.F90
@@ -51,58 +51,79 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetMultiIndices1
-INTEGER(I4B) :: ii, m
-INTEGER(I4B), ALLOCATABLE :: indx(:, :), acol(:), indx2(:, :)
+INTEGER(I4B) :: nrow, ncol
+nrow = d + 1
+ncol = SIZE(n=n, d=d)
+ALLOCATE (ans(nrow, ncol))
+CALL GetMultiIndices_(n=n, d=d, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE obj_GetMultiIndices1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-SELECT CASE (d)
-CASE (1_I4B)
+MODULE PROCEDURE obj_GetMultiIndices1_
+INTEGER(I4B) :: ii, aint, bint, tsize
- ALLOCATE (ans(2, n + 1))
- DO ii = 0, n
- ans(1:2, ii + 1) = [ii, n - ii]
- END DO
+IF (d .EQ. 1) THEN
-CASE DEFAULT
+ nrow = 2
+ ncol = n + 1
- ALLOCATE (ans(d + 1, 1))
- ans = 0; ans(1, 1) = n
+ DO ii = 0, n
+ ans(1, ii + 1) = ii
+ ans(2, ii + 1) = n - ii
+ END DO
- DO ii = n - 1, 0_I4B, -1_I4B
+ RETURN
+END IF
- 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
+nrow = d + 1
+ncol = SIZE(n=n, d=d)
- END DO
+ans(1:nrow, 1:ncol) = 0
+ans(1, ncol) = n
-END SELECT
+bint = ncol
-IF (ALLOCATED(indx)) DEALLOCATE (indx)
-IF (ALLOCATED(acol)) DEALLOCATE (acol)
-IF (ALLOCATED(indx2)) DEALLOCATE (indx2)
+DO ii = n - 1, 0_I4B, -1_I4B
+ tsize = SIZE(n=n - ii, d=d - 1)
+ bint = bint - tsize
+ ans(1, bint:bint + tsize - 1) = ii
+ CALL GetMultiIndices_(n=n - ii, d=d - 1, ans=ans(2:, bint:), nrow=aint, &
+ ncol=tsize)
+END DO
-END PROCEDURE obj_GetMultiIndices1
+END PROCEDURE obj_GetMultiIndices1_
!----------------------------------------------------------------------------
-!
+! GetMultiIndices_
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_GetMultiIndices2
-INTEGER(I4B) :: ii, m, r1, r2
+MODULE PROCEDURE obj_GetMultiIndices2_
+INTEGER(I4B) :: ii, aint, bint, indx
-m = SIZE(n, d, .TRUE.)
-ALLOCATE (ans(d + 1, m))
+nrow = d + 1
+ncol = SIZE(n, d, .TRUE.)
-r1 = 0; r2 = 0
+indx = 1
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)
+ CALL GetMultiIndices_(n=ii, d=d, ans=ans(:, indx:), nrow=aint, ncol=bint)
+ indx = indx + bint
END DO
+END PROCEDURE obj_GetMultiIndices2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetMultiIndices2
+INTEGER(I4B) :: nrow, ncol
+nrow = d + 1
+ncol = SIZE(n=n, d=d, upto=upto)
+ALLOCATE (ans(nrow, ncol))
+CALL GetMultiIndices_(n=n, d=d, ans=ans, nrow=nrow, ncol=ncol, upto=upto)
END PROCEDURE obj_GetMultiIndices2
!----------------------------------------------------------------------------
@@ -110,19 +131,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE in_1a
-#include "./In/In_1.inc"
+#include "./In/In_1.F90"
END PROCEDURE in_1a
MODULE PROCEDURE in_1b
-#include "./In/In_1.inc"
+#include "./In/In_1.F90"
END PROCEDURE in_1b
MODULE PROCEDURE in_1c
-#include "./In/In_1.inc"
+#include "./In/In_1.F90"
END PROCEDURE in_1c
MODULE PROCEDURE in_1d
-#include "./In/In_1.inc"
+#include "./In/In_1.F90"
END PROCEDURE in_1d
!----------------------------------------------------------------------------
@@ -130,19 +151,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE IsIn_1a
-#include "./In/IsIn_1.inc"
+#include "./In/IsIn_1.F90"
END PROCEDURE IsIn_1a
MODULE PROCEDURE IsIn_1b
-#include "./In/IsIn_1.inc"
+#include "./In/IsIn_1.F90"
END PROCEDURE IsIn_1b
MODULE PROCEDURE IsIn_1c
-#include "./In/IsIn_1.inc"
+#include "./In/IsIn_1.F90"
END PROCEDURE IsIn_1c
MODULE PROCEDURE IsIn_1d
-#include "./In/IsIn_1.inc"
+#include "./In/IsIn_1.F90"
END PROCEDURE IsIn_1d
!----------------------------------------------------------------------------
@@ -358,4 +379,29 @@
#include "./Intersection/Intersection.inc"
END PROCEDURE GetIntersection4
+!----------------------------------------------------------------------------
+! Get1DIndexFrom2DFortranIndex
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Get1DIndexFrom2DFortranIndex
+ans = (j - 1) * dim1 + i
+END PROCEDURE Get1DIndexFrom2DFortranIndex
+
+!----------------------------------------------------------------------------
+! Get1DIndexFrom2DFortranIndex
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Get1DIndexFrom3DFortranIndex
+ans = (k - 1) * dim1 * dim2 + (j - 1) * dim1 + i
+END PROCEDURE Get1DIndexFrom3DFortranIndex
+
+!----------------------------------------------------------------------------
+! Get1DIndexFrom2DFortranIndex
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Get1DIndexFrom4DFortranIndex
+ans = (l - 1) * dim1 * dim2 * dim3 + (k - 1) * dim1 * dim2 &
+ + (j - 1) * dim1 + i
+END PROCEDURE Get1DIndexFrom4DFortranIndex
+
END SUBMODULE Methods
diff --git a/src/submodules/Utility/src/MappingUtility@Methods.F90 b/src/submodules/Utility/src/MappingUtility@Methods.F90
index c5dbf2273..e39785260 100644
--- a/src/submodules/Utility/src/MappingUtility@Methods.F90
+++ b/src/submodules/Utility/src/MappingUtility@Methods.F90
@@ -16,16 +16,18 @@
SUBMODULE(MappingUtility) Methods
USE BaseMethod, ONLY: UpperCase, &
- & SOFTLE, &
- & RefCoord_Tetrahedron, &
- & RefCoord_Hexahedron, &
- & TriangleArea2D, &
- & TriangleArea3D, &
- & QuadrangleArea2D, &
- & QuadrangleArea3D, &
- & TetrahedronVolume3D, &
- & HexahedronVolume3D
+ SOFTLE, &
+ RefCoord_Tetrahedron, &
+ RefCoord_Hexahedron, &
+ TriangleArea2D, &
+ TriangleArea3D, &
+ QuadrangleArea2D, &
+ QuadrangleArea3D, &
+ TetrahedronVolume3D, &
+ HexahedronVolume3D
+
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -40,6 +42,15 @@
! FromBiunitLine2Segment
!----------------------------------------------------------------------------
+MODULE PROCEDURE FromBiunitLine2Segment1_
+tsize = SIZE(xin)
+ans(1:tsize) = 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)
@@ -47,6 +58,19 @@
END DO
END PROCEDURE FromBiunitLine2Segment2
+!----------------------------------------------------------------------------
+! FromBiunitLine2Segment
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiunitLine2Segment2_
+INTEGER(I4B) :: ii
+nrow = SIZE(x1)
+ncol = SIZE(xin)
+DO ii = 1, ncol
+ ans(1:nrow, ii) = 0.5_DFP * (x1 + x2) + 0.5_DFP * (x2 - x1) * xin(ii)
+END DO
+END PROCEDURE FromBiunitLine2Segment2_
+
!----------------------------------------------------------------------------
! FromBiUnitLine2UnitLine
!----------------------------------------------------------------------------
@@ -60,9 +84,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromUnitLine2BiUnitLine
-ans = 2.0_DFP * xin - 1.0_DFP
+INTEGER(I4B) :: tsize
+CALL FromUnitLine2BiUnitLine_(xin=xin, ans=ans, tsize=tsize)
END PROCEDURE FromUnitLine2BiUnitLine
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnitLine2BiUnitLine_
+tsize = SIZE(xin)
+ans(1:tsize) = 2.0_DFP * xin(1:tsize) - 1.0_DFP
+END PROCEDURE FromUnitLine2BiUnitLine_
+
!----------------------------------------------------------------------------
! FromLine2Line
!----------------------------------------------------------------------------
@@ -108,19 +142,44 @@
END DO
END PROCEDURE FromUnitTriangle2Triangle1
+!----------------------------------------------------------------------------
+! FromUnitTriangle2Triangle_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnitTriangle2Triangle1_
+INTEGER(I4B) :: ii, jj
+
+nrow = SIZE(x1)
+ncol = SIZE(xin, 2)
+
+DO CONCURRENT(jj=1:ncol, ii=1:nrow)
+ ans(ii, jj) = x1(ii) + (x2(ii) - x1(ii)) * xin(1, jj) &
+ + (x3(ii) - x1(ii)) * xin(2, jj)
+END DO
+END PROCEDURE FromUnitTriangle2Triangle1_
+
!----------------------------------------------------------------------------
! FromBiUnitQuadrangle2UnitQuadrangle
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1
-ans = FromBiUnitQuadrangle2Quadrangle(&
- & xin=xin, &
- & x1=[0.0_DFP, 0.0_DFP], &
- & x2=[1.0_DFP, 0.0_DFP], &
- & x3=[1.0_DFP, 1.0_DFP], &
- & x4=[0.0_DFP, 1.0_DFP])
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitQuadrangle2UnitQuadrangle1_(xin=xin, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1_
+REAL(DFP), PARAMETER :: azero = 0.0_DFP, aone = 1.0_DFP
+REAL(DFP), PARAMETER :: x1(2) = [azero, azero], x2(2) = [aone, azero], &
+ x3(2) = [aone, aone], x4(2) = [azero, aone]
+CALL FromBiUnitQuadrangle2Quadrangle_(xin=xin, x1=x1, x2=x2, x3=x3, x4=x4, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE FromBiUnitQuadrangle2UnitQuadrangle1_
+
!----------------------------------------------------------------------------
! FromBiUnitQuadrangle2UnitQuadrangle
!----------------------------------------------------------------------------
@@ -149,30 +208,58 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitQuadrangle2Quadrangle1
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitQuadrangle2Quadrangle1_(xin=xin, ans=ans, x1=x1, x2=x2, &
+ x3=x3, x4=x4, nrow=nrow, ncol=ncol)
+END PROCEDURE FromBiUnitQuadrangle2Quadrangle1
+
+!----------------------------------------------------------------------------
+! FromBiUnitQuadrangle2Quadrangle_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiUnitQuadrangle2Quadrangle1_
INTEGER(I4B) :: ii
REAL(DFP) :: xi, eta, p1, p2, p3, p4
-!!
-DO ii = 1, SIZE(ans, 2)
+
+! ans(SIZE(x1), SIZE(xin, 2))
+nrow = SIZE(x1)
+ncol = SIZE(xin, 2)
+
+DO ii = 1, ncol
xi = xin(1, ii)
eta = xin(2, ii)
p1 = 0.25 * (1.0 - xi) * (1.0 - eta)
p2 = 0.25 * (1.0 + xi) * (1.0 - eta)
p3 = 0.25 * (1.0 + xi) * (1.0 + eta)
p4 = 0.25 * (1.0 - xi) * (1.0 + eta)
- ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4
+ ans(1:nrow, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4
END DO
-END PROCEDURE FromBiUnitQuadrangle2Quadrangle1
+END PROCEDURE FromBiUnitQuadrangle2Quadrangle1_
!----------------------------------------------------------------------------
! FromBiUnitHexahedron2Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitHexahedron2Hexahedron1
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitHexahedron2Hexahedron1_(xin, x1, x2, x3, x4, x5, x6, x7, x8, &
+ ans, nrow, ncol)
+
+END PROCEDURE FromBiUnitHexahedron2Hexahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiUnitHexahedron2Hexahedron1_
INTEGER(I4B) :: ii
REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta
REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP
-DO ii = 1, SIZE(ans, 2)
+nrow = SIZE(x1)
+ncol = SIZE(xin, 2)
+
+DO ii = 1, ncol
xi = xin(1, ii)
eta = xin(2, ii)
zeta = xin(3, ii)
@@ -184,35 +271,48 @@
p6 = p125 * (one + xi) * (one - eta) * (one + zeta)
p7 = p125 * (one + xi) * (one + eta) * (one + zeta)
p8 = p125 * (one - xi) * (one + eta) * (one + zeta)
- ans(:, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + &
- & x5 * p5 + x6 * p6 + x7 * p7 + x8 * p8
+ ans(1:nrow, ii) = x1 * p1 + x2 * p2 + x3 * p3 + x4 * p4 + &
+ x5 * p5 + x6 * p6 + x7 * p7 + x8 * p8
END DO
-END PROCEDURE FromBiUnitHexahedron2Hexahedron1
+END PROCEDURE FromBiUnitHexahedron2Hexahedron1_
!----------------------------------------------------------------------------
! FromBiUnitHexahedron2UnitHexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitHexahedron2UnitHexahedron1
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitHexahedron2UnitHexahedron1_(xin, ans, nrow, ncol)
+END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiUnitHexahedron2UnitHexahedron1_
REAL(DFP) :: xij(3, 8)
+
xij = RefCoord_Hexahedron(refHexahedron="UNIT")
-ans = FromBiUnitHexahedron2Hexahedron(&
- & xin=xin, &
- & x1=xij(:, 1), &
- & x2=xij(:, 2), &
- & x3=xij(:, 3), &
- & x4=xij(:, 4), &
- & x5=xij(:, 5), &
- & x6=xij(:, 6), &
- & x7=xij(:, 7), &
- & x8=xij(:, 8))
-END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1
+
+CALL FromBiUnitHexahedron2Hexahedron_(xin=xin, x1=xij(:, 1), x2=xij(:, 2), &
+ x3=xij(:, 3), x4=xij(:, 4), x5=xij(:, 5), x6=xij(:, 6), x7=xij(:, 7), &
+ x8=xij(:, 8), ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE FromBiUnitHexahedron2UnitHexahedron1_
!----------------------------------------------------------------------------
! FromBiUnitHexahedron2Hexahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE FromUnitHexahedron2BiUnitHexahedron1
+INTEGER(I4B) :: nrow, ncol
+CALL FromUnitHexahedron2BiUnitHexahedron1_(xin, ans, nrow, ncol)
+END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnitHexahedron2BiUnitHexahedron1_
INTEGER(I4B) :: ii
REAL(DFP) :: xi, eta, p1, p2, p3, p4, p5, p6, p7, p8, zeta
REAL(DFP), PARAMETER :: one = 1.0_DFP, p125 = 0.125_DFP
@@ -220,7 +320,10 @@
x = RefCoord_Hexahedron(refHexahedron="BIUNIT")
-DO ii = 1, SIZE(ans, 2)
+nrow = SIZE(xin, 1)
+ncol = SIZE(xin, 2)
+
+DO ii = 1, ncol
xi = xin(1, ii)
eta = xin(2, ii)
zeta = xin(3, ii)
@@ -232,10 +335,11 @@
p6 = (xi) * (one - eta) * (zeta)
p7 = (xi) * (eta) * (zeta)
p8 = (one - xi) * (eta) * (zeta)
- ans(:, ii) = x(:, 1) * p1 + x(:, 2) * p2 + x(:, 3) * p3 + x(:, 4) * p4 + &
- & x(:, 5) * p5 + x(:, 6) * p6 + x(:, 7) * p7 + x(:, 8) * p8
+ ans(1:nrow, ii) = x(1:nrow, 1) * p1 + x(1:nrow, 2) * p2 + x(1:nrow, 3) * p3 &
+ + x(1:nrow, 4) * p4 + x(1:nrow, 5) * p5 + x(1:nrow, 6) * p6 &
+ + x(1:nrow, 7) * p7 + x(1:nrow, 8) * p8
END DO
-END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1
+END PROCEDURE FromUnitHexahedron2BiUnitHexahedron1_
!----------------------------------------------------------------------------
! FromTriangle2Square_
@@ -275,6 +379,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromUnitTriangle2BiUnitSqr
+INTEGER(I4B) :: nrow, ncol
CALL FromTriangle2Square_(xin=xin, ans=ans, from="U", to="B")
END PROCEDURE FromUnitTriangle2BiUnitSqr
@@ -283,21 +388,46 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromSquare2Triangle_
+REAL(DFP) :: rr(4)
+INTEGER(I4B) :: ii
CHARACTER(2) :: acase
-acase = from(1:1)//to(1:1)
+
+acase(1:1) = UpperCase(from(1:1))
+acase(2:2) = UpperCase(to(1:1))
+
+nrow = 2
+ncol = SIZE(xin, 2)
SELECT CASE (acase)
-CASE ("BB", "bb", "Bb", "bB")
+CASE ("BB")
- ans(1, :) = 0.5_DFP * (1.0_DFP + xin(1, :)) * (1.0_DFP - xin(2, :)) &
- - 1.0_DFP
- ans(2, :) = xin(2, :)
+ DO ii = 1, ncol
+
+ rr(1) = xin(2, ii)
+ rr(2) = xin(1, ii)
+ rr(3) = 0.5_DFP * (1.0_DFP + rr(2))
+ rr(4) = 1.0_DFP - rr(1)
+ rr(2) = rr(3) * rr(4) - 1.0_DFP
-CASE ("BU", "bu", "Bu", "bU")
+ ans(1, ii) = rr(2)
+ ans(2, ii) = rr(1)
+
+ END DO
- 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)
+CASE ("BU")
+
+ DO ii = 1, ncol
+ rr(1) = xin(1, ii)
+ rr(2) = xin(2, ii)
+ rr(3) = 0.25_DFP * (1.0_DFP + rr(1))
+ rr(4) = 1.0_DFP - rr(2)
+ rr(1) = rr(3) * rr(4)
+ rr(3) = 0.5_DFP * (rr(2) + 1.0_DFP)
+
+ ans(1, ii) = rr(1)
+ ans(2, ii) = rr(3)
+ END DO
END SELECT
END PROCEDURE FromSquare2Triangle_
@@ -307,7 +437,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitSqr2BiUnitTriangle
-CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="B")
+INTEGER(I4B) :: nrow, ncol
+CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="B", nrow=nrow, &
+ ncol=ncol)
END PROCEDURE FromBiUnitSqr2BiUnitTriangle
!----------------------------------------------------------------------------
@@ -315,7 +447,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitSqr2UnitTriangle
-CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="U")
+INTEGER(I4B) :: nrow, ncol
+CALL FromSquare2Triangle_(xin=xin, ans=ans, from="B", to="U", nrow=nrow, &
+ ncol=ncol)
END PROCEDURE FromBiUnitSqr2UnitTriangle
!----------------------------------------------------------------------------
@@ -366,25 +500,41 @@
MODULE PROCEDURE FromTriangle2Triangle_
CHARACTER(2) :: acase
-INTEGER(I4B) :: ii, n
+INTEGER(I4B) :: ii, jj
+REAL(DFP) :: x21(3), x31(3)
-acase = from(1:1)//to(1:1)
+ncol = SIZE(xin, 2)
+
+acase(1:1) = Uppercase(from(1:1))
+acase(2:2) = Uppercase(to(1:1))
SELECT CASE (acase)
-CASE ("BU", "bu", "bU", "Bu")
+CASE ("BU")
- ans = 0.5_DFP * (1.0_DFP + xin)
+ nrow = SIZE(xin, 1)
-CASE ("UB", "ub", "Ub", "uB")
+ DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = 0.5_DFP * (1.0_DFP + xin(ii, jj))
+ END DO
- ans = -1.0_DFP + 2.0_DFP * xin
+CASE ("UB")
-CASE ("UT", "ut", "Ut", "uT")
+ nrow = SIZE(xin, 1)
- n = SIZE(xin, 2)
- DO CONCURRENT(ii=1:n)
- ans(:, ii) = x1 + (x2 - x1) * xin(1, ii) + (x3 - x1) * xin(2, ii)
+ DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = -1.0_DFP + 2.0_DFP * xin(ii, jj)
+ END DO
+
+CASE ("UT")
+
+ nrow = SIZE(x1)
+
+ x21(1:nrow) = x2(1:nrow) - x1(1:nrow)
+ x31(1:nrow) = x3(1:nrow) - x1(1:nrow)
+
+ DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = x1(ii) + x21(ii) * xin(1, jj) + x31(ii) * xin(2, jj)
END DO
END SELECT
@@ -395,7 +545,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitTriangle2UnitTriangle
-CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="B", to="U")
+INTEGER(I4B) :: nrow, ncol
+CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="B", to="U", nrow=nrow, &
+ ncol=ncol)
END PROCEDURE FromBiUnitTriangle2UnitTriangle
!----------------------------------------------------------------------------
@@ -403,7 +555,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromUnitTriangle2BiUnitTriangle
-CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="U", to="B")
+INTEGER(I4B) :: nrow, ncol
+CALL FromTriangle2Triangle_(xin=xin, ans=ans, from="U", to="B", nrow=nrow, &
+ ncol=ncol)
END PROCEDURE FromUnitTriangle2BiUnitTriangle
!----------------------------------------------------------------------------
@@ -411,17 +565,53 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron
-ans = 0.5_DFP * (1.0_DFP + xin)
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitTetrahedron2UnitTetrahedron_(xin, ans, nrow, ncol)
END PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron_
+INTEGER(I4B) :: ii, jj
+REAL(DFP), PARAMETER :: half = 0.5_DFP, one = 1.0_DFP
+
+nrow = SIZE(xin, 1)
+ncol = SIZE(xin, 2)
+
+DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = half * (one + xin(ii, jj))
+END DO
+
+END PROCEDURE FromBiUnitTetrahedron2UnitTetrahedron_
+
!----------------------------------------------------------------------------
! FromUnitTetrahedron2BiUnitTetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron
-ans = -1.0_DFP + 2.0_DFP * xin
+INTEGER(I4B) :: nrow, ncol
+CALL FromUnitTetrahedron2BiUnitTetrahedron_(xin, ans, nrow, ncol)
END PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron_
+REAL(DFP), PARAMETER :: minus_one = -1.0_DFP, two = 2.0_DFP
+INTEGER(I4B) :: ii, jj
+
+nrow = SIZE(xin, 1)
+ncol = SIZE(xin, 2)
+
+DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = minus_one + two * xin(ii, jj)
+END DO
+
+END PROCEDURE FromUnitTetrahedron2BiUnitTetrahedron_
+
!----------------------------------------------------------------------------
! FromBiUnitTetrahedron2Tetrahedron
!----------------------------------------------------------------------------
@@ -442,50 +632,113 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron
+INTEGER(I4B) :: nrow, ncol
+CALL FromUnitTetrahedron2Tetrahedron_(xin=xin, ans=ans, x1=x1, x2=x2, &
+ x3=x3, x4=x4, nrow=nrow, ncol=ncol)
+END PROCEDURE FromUnitTetrahedron2Tetrahedron
+
+!----------------------------------------------------------------------------
+! FromUnitTetrahedron2Tetrahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromUnitTetrahedron2Tetrahedron_
INTEGER(I4B) :: ii
-DO ii = 1, SIZE(xin, 2)
- ans(:, ii) = &
- (1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)) * x1(:) &
- + xin(1, ii) * x2(:) &
- + xin(2, ii) * x3(:) &
- + xin(3, ii) * x4(:)
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+REAL(DFP) :: rr(10)
+
+nrow = SIZE(x1)
+ncol = SIZE(xin, 2)
+
+DO ii = 1, ncol
+
+ rr(1:3) = xin(1:3, ii)
+ rr(4) = one - rr(1) - rr(2) - rr(3)
+
+ ans(1:nrow, ii) = rr(4) * x1(1:nrow) + rr(1) * x2(1:nrow) + rr(2) * x3(1:nrow) &
+ + rr(3) * x4(1:nrow)
END DO
-END PROCEDURE FromUnitTetrahedron2Tetrahedron
+END PROCEDURE FromUnitTetrahedron2Tetrahedron_
!----------------------------------------------------------------------------
! BarycentricCoordUnitTetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricCoordUnitTetrahedron
-ans(1, :) = 1.0_DFP - xin(1, :) - xin(2, :) - xin(3, :)
-ans(2, :) = xin(1, :)
-ans(3, :) = xin(2, :)
-ans(4, :) = xin(3, :)
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricCoordUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE BarycentricCoordUnitTetrahedron
+!----------------------------------------------------------------------------
+! BarycentricCoordUnitTetrahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricCoordUnitTetrahedron_
+INTEGER(I4B) :: ii
+
+nrow = 4
+ncol = SIZE(xin, 2)
+
+DO CONCURRENT(ii=1:ncol)
+ ans(1, ii) = 1.0_DFP - xin(1, ii) - xin(2, ii) - xin(3, ii)
+ ans(2, ii) = xin(1, ii)
+ ans(3, ii) = xin(2, ii)
+ ans(4, ii) = xin(3, ii)
+END DO
+END PROCEDURE BarycentricCoordUnitTetrahedron_
+
!----------------------------------------------------------------------------
! BarycentricCoordBiUnitTetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricCoordBiUnitTetrahedron
-ans(1, :) = -0.5_DFP * (1.0_DFP + xin(1, :) + xin(2, :) + xin(3, :))
-ans(2, :) = 0.5_DFP * (1.0_DFP + xin(1, :))
-ans(3, :) = 0.5_DFP * (1.0_DFP + xin(2, :))
-ans(4, :) = 0.5_DFP * (1.0_DFP + xin(3, :))
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricCoordBiUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, &
+ ncol=ncol)
END PROCEDURE BarycentricCoordBiUnitTetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricCoordBiUnitTetrahedron_
+INTEGER(I4B) :: ii
+
+nrow = 4
+ncol = SIZE(xin, 2)
+
+DO CONCURRENT(ii=1:ncol)
+ ans(1, ii) = -0.5_DFP * (1.0_DFP + xin(1, ii) + xin(2, ii) + xin(3, ii))
+ ans(2, ii) = 0.5_DFP * (1.0_DFP + xin(1, ii))
+ ans(3, ii) = 0.5_DFP * (1.0_DFP + xin(2, ii))
+ ans(4, ii) = 0.5_DFP * (1.0_DFP + xin(3, ii))
+END DO
+
+END PROCEDURE BarycentricCoordBiUnitTetrahedron_
+
!----------------------------------------------------------------------------
! BarycentricCoordTetrahedron
!----------------------------------------------------------------------------
MODULE PROCEDURE BarycentricCoordTetrahedron
+INTEGER(I4B) :: nrow, ncol
+CALL BarycentricCoordTetrahedron_(xin=xin, refTetrahedron=refTetrahedron, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE BarycentricCoordTetrahedron
+
+!----------------------------------------------------------------------------
+! BarycentricCoordTetrahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BarycentricCoordTetrahedron_
SELECT CASE (refTetrahedron(1:1))
CASE ("B", "b")
- ans = BarycentricCoordBiUnitTetrahedron(xin)
+ CALL BarycentricCoordBiUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, &
+ ncol=ncol)
CASE ("U", "u")
- ans = BarycentricCoordUnitTetrahedron(xin)
+ CALL BarycentricCoordUnitTetrahedron_(xin=xin, ans=ans, nrow=nrow, &
+ ncol=ncol)
END SELECT
-END PROCEDURE BarycentricCoordTetrahedron
+END PROCEDURE BarycentricCoordTetrahedron_
!----------------------------------------------------------------------------
! FromBiUnitTetrahedron2BiUnitHexahedron
@@ -523,17 +776,41 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron
-ans(1, :) = 0.25_DFP &
- & * (1.0_DFP + xin(1, :)) &
- & * (1.0_DFP - xin(2, :)) &
- & * (1.0_DFP - xin(3, :)) - 1.0_DFP
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitHexahedron2BiUnitTetrahedron_(xin, ans, nrow, ncol)
+END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
-ans(2, :) = 0.5_DFP &
- & * (1.0_DFP + xin(2, :)) &
- & * (1.0_DFP - xin(3, :)) - 1.0_DFP
+MODULE PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron_
-ans(3, :) = xin(3, :)
-END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron
+INTEGER(I4B) :: ii
+REAL(DFP) :: rr(10)
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+
+nrow = 3
+ncol = SIZE(xin, 2)
+
+DO ii = 1, ncol
+
+ rr(1:3) = xin(1:3, ii)
+
+ rr(4) = one + rr(1)
+ rr(5) = one - rr(2)
+ rr(6) = one - rr(3)
+ rr(7) = 0.25_DFP * rr(4) * rr(5) * rr(6)
+ rr(8) = one + rr(2)
+ rr(9) = 0.5_DFP * rr(8) * rr(6)
+
+ ans(1, ii) = rr(7) - one
+ ans(2, ii) = rr(9) - one
+ ans(3, ii) = rr(3)
+
+END DO
+
+END PROCEDURE FromBiUnitHexahedron2BiUnitTetrahedron_
!----------------------------------------------------------------------------
! FromUnitTetrahedron2BiUnitHexahedron
@@ -549,10 +826,24 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE FromBiUnitHexahedron2UnitTetrahedron
-ans = FromBiUnitTetrahedron2UnitTetrahedron( &
- & FromBiUnitHexahedron2BiUnitTetrahedron(xin))
+INTEGER(I4B) :: nrow, ncol
+CALL FromBiUnitHexahedron2UnitTetrahedron_(xin, ans, nrow, ncol)
END PROCEDURE FromBiUnitHexahedron2UnitTetrahedron
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FromBiUnitHexahedron2UnitTetrahedron_
+
+CALL FromBiUnitHexahedron2BiUnitTetrahedron_(xin=xin, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+CALL FromBiUnitTetrahedron2UnitTetrahedron_(xin=ans, ans=ans, nrow=nrow, &
+ ncol=ncol)
+
+END PROCEDURE FromBiUnitHexahedron2UnitTetrahedron_
+
!----------------------------------------------------------------------------
! JacobianLine
!----------------------------------------------------------------------------
diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90
index e68c7588c..2ec17697f 100644
--- a/src/submodules/Utility/src/ProductUtility@Methods.F90
+++ b/src/submodules/Utility/src/ProductUtility@Methods.F90
@@ -17,13 +17,54 @@
!> author: Vikas Sharma, Ph. D.
! date: 22 March 2021
-! summary: This submodule contains outerprod
+! summary: This submodule contains OuterProd
SUBMODULE(ProductUtility) Methods
-USE BaseMethod
IMPLICIT NONE
CONTAINS
+!----------------------------------------------------------------------------
+! OTimesTilda
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OTimesTilda1
+INTEGER(I4B) :: sa(2), sb(2)
+INTEGER(I4B) :: ii, jj, pp, qq
+
+sa = SHAPE(a)
+sb = SHAPE(b)
+
+nrow = sa(1) * sb(1)
+ncol = sa(2) * sb(2)
+
+DO CONCURRENT(ii=1:sa(1), jj=1:sa(2), pp=1:sb(1), qq=1:sb(2))
+ ans((ii - 1) * sb(1) + pp, (jj - 1) * sb(2) + qq) = &
+ anscoeff * ans((ii - 1) * sb(1) + pp, (jj - 1) * sb(2) + qq) + &
+ scale * a(ii, jj) * b(pp, qq)
+END DO
+
+END PROCEDURE OTimesTilda1
+
+!----------------------------------------------------------------------------
+! OTimesTilda
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OTimesTilda2
+INTEGER(I4B) :: sa, sb
+INTEGER(I4B) :: ii, jj
+
+sa = SIZE(a)
+sb = SIZE(b)
+
+tsize = sa * sb
+
+DO CONCURRENT(ii=1:sa, jj=1:sb)
+ ans((ii - 1) * sb + jj) = &
+ anscoeff * ans((ii - 1) * sb + jj) + scale * a(ii) * b(jj)
+END DO
+
+END PROCEDURE OTimesTilda2
+
!----------------------------------------------------------------------------
! VectorProd
!----------------------------------------------------------------------------
@@ -48,453 +89,509 @@
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1
+MODULE PROCEDURE OuterProd_r1r1
ans = 0.0_DFP
ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * &
- & SPREAD(b, dim=1, ncopies=SIZE(a))
-END PROCEDURE outerprod_r1r1
+ SPREAD(b, dim=1, ncopies=SIZE(a))
+END PROCEDURE OuterProd_r1r1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OuterProd_r1r1_
+INTEGER(I4B) :: ii, jj
+
+nrow = SIZE(a)
+ncol = SIZE(b)
+DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = anscoeff * ans(ii, jj) + scale * a(ii) * b(jj)
+END DO
+END PROCEDURE OuterProd_r1r1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OuterProd_r1r1s_
+INTEGER(I4B) :: ii, jj
+REAL(DFP) :: s
+
+IF (sym) THEN
+ nrow = SIZE(a)
+ ncol = SIZE(b)
+ s = 0.5_DFP * scale
+
+ DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = anscoeff * ans(ii, jj) + s * a(ii) * b(jj) + &
+ s * b(ii) * a(jj)
+ END DO
+
+ RETURN
+END IF
+
+CALL OuterProd_(a=a, b=b, ans=ans, anscoeff=anscoeff, scale=scale, &
+ nrow=nrow, ncol=ncol)
+
+END PROCEDURE OuterProd_r1r1s_
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1s
+MODULE PROCEDURE OuterProd_r1r1s
ans = 0.0_DFP
IF (Sym) THEN
ans = SPREAD(0.5_DFP * a, dim=2, ncopies=SIZE(b)) &
- & * SPREAD(b, dim=1, ncopies=SIZE(a)) &
- & + SPREAD(0.5_DFP * b, dim=2, ncopies=SIZE(a)) &
- & * SPREAD(a, dim=1, ncopies=SIZE(b))
+ * SPREAD(b, dim=1, ncopies=SIZE(a)) &
+ + SPREAD(0.5_DFP * b, dim=2, ncopies=SIZE(a)) &
+ * SPREAD(a, dim=1, ncopies=SIZE(b))
ELSE
ans = SPREAD(a, dim=2, ncopies=SIZE(b)) * &
- & SPREAD(b, dim=1, ncopies=SIZE(a))
+ SPREAD(b, dim=1, ncopies=SIZE(a))
END IF
-END PROCEDURE outerprod_r1r1s
+END PROCEDURE OuterProd_r1r1s
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OuterProd_r1r2
+INTEGER(I4B) :: ii
+DO ii = 1, SIZE(b, 2)
+ ans(:, :, ii) = OuterProd(a, b(:, ii))
+END DO
+END PROCEDURE OuterProd_r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2
+MODULE PROCEDURE OuterProd_r1r2_
INTEGER(I4B) :: ii
-do ii = 1, size(b, 2)
- ans(:, :, ii) = outerprod(a, b(:, ii))
-end do
-END PROCEDURE outerprod_r1r2
+dim1 = SIZE(a)
+dim2 = SIZE(b, 1)
+dim3 = SIZE(b, 2)
+DO ii = 1, dim3
+ CALL OuterProd_(a=a, b=b(1:dim2, ii), ans=ans(1:dim1, 1:dim2, ii), &
+ anscoeff=anscoeff, scale=scale, &
+ nrow=dim1, ncol=dim2)
+END DO
+END PROCEDURE OuterProd_r1r2_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3
+MODULE PROCEDURE OuterProd_r1r3
INTEGER(I4B) :: ii
-do ii = 1, size(b, 3)
- ans(:, :, :, ii) = outerprod(a, b(:, :, ii))
-end do
-END PROCEDURE outerprod_r1r3
+DO ii = 1, SIZE(b, 3)
+ ans(:, :, :, ii) = OuterProd(a, b(:, :, ii))
+END DO
+END PROCEDURE OuterProd_r1r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r4
+MODULE PROCEDURE OuterProd_r1r4
INTEGER(I4B) :: ii
-do ii = 1, size(b, 4)
- ans(:, :, :, :, ii) = outerprod(a, b(:, :, :, ii))
-end do
-END PROCEDURE outerprod_r1r4
+DO ii = 1, SIZE(b, 4)
+ ans(:, :, :, :, ii) = OuterProd(a, b(:, :, :, ii))
+END DO
+END PROCEDURE OuterProd_r1r4
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r5
+MODULE PROCEDURE OuterProd_r1r5
INTEGER(I4B) :: ii
-do ii = 1, size(b, 5)
- ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, :, ii))
-end do
-END PROCEDURE outerprod_r1r5
+DO ii = 1, SIZE(b, 5)
+ ans(:, :, :, :, :, ii) = OuterProd(a, b(:, :, :, :, ii))
+END DO
+END PROCEDURE OuterProd_r1r5
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1
+MODULE PROCEDURE OuterProd_r2r1
INTEGER(I4B) :: ii
-do ii = 1, size(b, 1)
+DO ii = 1, SIZE(b, 1)
ans(:, :, ii) = a * b(ii)
-end do
-END PROCEDURE outerprod_r2r1
+END DO
+END PROCEDURE OuterProd_r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r2
+MODULE PROCEDURE OuterProd_r2r2
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 2)
- ans(:, :, :, ii) = outerprod(a, b(:, ii))
+ ans(:, :, :, ii) = OuterProd(a, b(:, ii))
END DO
-END PROCEDURE outerprod_r2r2
+END PROCEDURE OuterProd_r2r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r3
+MODULE PROCEDURE OuterProd_r2r3
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 3)
- ans(:, :, :, :, ii) = outerprod(a, b(:, :, ii))
+ ans(:, :, :, :, ii) = OuterProd(a, b(:, :, ii))
END DO
-END PROCEDURE outerprod_r2r3
+END PROCEDURE OuterProd_r2r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r4
+MODULE PROCEDURE OuterProd_r2r4
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 4)
- ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, :, ii))
+ ans(:, :, :, :, :, ii) = OuterProd(a, b(:, :, :, ii))
END DO
-END PROCEDURE outerprod_r2r4
+END PROCEDURE OuterProd_r2r4
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r1
+MODULE PROCEDURE OuterProd_r3r1
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 1)
ans(:, :, :, ii) = a(:, :, :) * b(ii)
END DO
-END PROCEDURE outerprod_r3r1
+END PROCEDURE OuterProd_r3r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r2
+MODULE PROCEDURE OuterProd_r3r2
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 2)
- ans(:, :, :, :, ii) = outerprod(a, b(:, ii))
+ ans(:, :, :, :, ii) = OuterProd(a, b(:, ii))
END DO
-END PROCEDURE outerprod_r3r2
+END PROCEDURE OuterProd_r3r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r3
+MODULE PROCEDURE OuterProd_r3r3
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 3)
- ans(:, :, :, :, :, ii) = outerprod(a, b(:, :, ii))
+ ans(:, :, :, :, :, ii) = OuterProd(a, b(:, :, ii))
END DO
-END PROCEDURE outerprod_r3r3
+END PROCEDURE OuterProd_r3r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r4r1
+MODULE PROCEDURE OuterProd_r4r1
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 1)
ans(:, :, :, :, ii) = a * b(ii)
END DO
-END PROCEDURE outerprod_r4r1
+END PROCEDURE OuterProd_r4r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r4r2
+MODULE PROCEDURE OuterProd_r4r2
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b, 2)
- ans(:, :, :, :, :, ii) = outerprod(a, b(:, ii))
+ ans(:, :, :, :, :, ii) = OuterProd(a, b(:, ii))
END DO
-END PROCEDURE outerprod_r4r2
+END PROCEDURE OuterProd_r4r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r5r1
+MODULE PROCEDURE OuterProd_r5r1
INTEGER(I4B) :: ii
DO ii = 1, SIZE(b)
ans(:, :, :, :, :, ii) = a * b(ii)
END DO
-END PROCEDURE outerprod_r5r1
+END PROCEDURE OuterProd_r5r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r1r1
+MODULE PROCEDURE OuterProd_r1r1r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r1r2
+MODULE PROCEDURE OuterProd_r1r1r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r3
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r1r3
+MODULE PROCEDURE OuterProd_r1r1r3
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r4
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r1r4
+MODULE PROCEDURE OuterProd_r1r1r4
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r4
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r2r1
+MODULE PROCEDURE OuterProd_r1r2r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r2r2
+MODULE PROCEDURE OuterProd_r1r2r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r2r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r3
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r2r3
+MODULE PROCEDURE OuterProd_r1r2r3
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r2r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r3r1
+MODULE PROCEDURE OuterProd_r1r3r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r3r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r3r2
+MODULE PROCEDURE OuterProd_r1r3r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r3r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r4r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r4r1
+MODULE PROCEDURE OuterProd_r1r4r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r4r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r2r1r1
+MODULE PROCEDURE OuterProd_r2r1r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r2r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r2r1r2
+MODULE PROCEDURE OuterProd_r2r1r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r2r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r3
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r2r1r3
+MODULE PROCEDURE OuterProd_r2r1r3
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r2r1r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r2r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r2r2r1
+MODULE PROCEDURE OuterProd_r2r2r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r2r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r2r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r2r2r2
+MODULE PROCEDURE OuterProd_r2r2r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r2r2r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r1r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r3r1r1
+MODULE PROCEDURE OuterProd_r3r1r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r3r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r1r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r3r1r2
+MODULE PROCEDURE OuterProd_r3r1r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r3r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r2r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r3r2r1
+MODULE PROCEDURE OuterProd_r3r2r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r3r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r4r1r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r4r1r1
+MODULE PROCEDURE OuterProd_r4r1r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r4r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r1r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r1r1r1
+MODULE PROCEDURE OuterProd_r1r1r1r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r1r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r1r2
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r1r1r2
+MODULE PROCEDURE OuterProd_r1r1r1r2
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r1r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r1r3
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r1r1r3
+MODULE PROCEDURE OuterProd_r1r1r1r3
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r1r1r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r2r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r1r2r1
+MODULE PROCEDURE OuterProd_r1r1r2r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r1r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r2r2
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r1r2r2
+MODULE PROCEDURE OuterProd_r1r1r2r2
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r1r2r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r3r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r1r3r1
+MODULE PROCEDURE OuterProd_r1r1r3r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r1r3r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r1r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r2r1r1
+MODULE PROCEDURE OuterProd_r1r2r1r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r2r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r1r2
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r2r1r2
+MODULE PROCEDURE OuterProd_r1r2r1r2
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r2r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r2r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r2r2r1
+MODULE PROCEDURE OuterProd_r1r2r2r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r2r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3r1r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r1r3r1r1
+MODULE PROCEDURE OuterProd_r1r3r1r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r1r3r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r1r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r2r1r1r1
+MODULE PROCEDURE OuterProd_r2r1r1r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r2r1r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r1r2
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r2r1r1r2
+MODULE PROCEDURE OuterProd_r2r1r1r2
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r2r1r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r2r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r2r1r2r1
+MODULE PROCEDURE OuterProd_r2r1r2r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r2r1r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r2r1r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r2r2r1r1
+MODULE PROCEDURE OuterProd_r2r2r1r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r2r2r1r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r3r1r1r1
-ans = outerprod(outerprod(a, outerprod(b, c)), d)
-END PROCEDURE outerprod_r3r1r1r1
+MODULE PROCEDURE OuterProd_r3r1r1r1
+ans = OuterProd(OuterProd(a, OuterProd(b, c)), d)
+END PROCEDURE OuterProd_r3r1r1r1
END SUBMODULE Methods
diff --git a/src/submodules/Utility/src/Reallocate/reallocate1.F90 b/src/submodules/Utility/src/Reallocate/reallocate1.F90
new file mode 100644
index 000000000..1f3d1e269
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate1.F90
@@ -0,0 +1,47 @@
+LOGICAL :: isok, abool, ex, acase
+INTEGER(I4B) :: ii, fac
+
+ex = .FALSE.
+IF (PRESENT(isExpand)) ex = isExpand
+
+fac = 1
+IF (PRESENT(expandFactor)) fac = expandFactor
+
+isok = ALLOCATED(mat)
+
+acase = isok .AND. (.NOT. ex)
+IF (acase) THEN
+ abool = SIZE(mat) .NE. row
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(row))
+ END IF
+
+ ! CALL setzeros
+ DO CONCURRENT(ii=1:row)
+ mat(ii) = ZEROVALUE
+ END DO
+ RETURN
+END IF
+
+acase = isok .AND. ex
+IF (acase) THEN
+
+ abool = SIZE(mat) .LT. row
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(row * fac))
+ END IF
+
+ DO CONCURRENT(ii=1:row)
+ mat(ii) = ZEROVALUE
+ END DO
+ RETURN
+END IF
+
+ALLOCATE (mat(row * fac))
+DO CONCURRENT(ii=1:row)
+ mat(ii) = ZEROVALUE
+END DO
+! CALL setzeros
diff --git a/src/submodules/Utility/src/Reallocate/reallocate10.F90 b/src/submodules/Utility/src/Reallocate/reallocate10.F90
new file mode 100644
index 000000000..b9d96a983
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate10.F90
@@ -0,0 +1,42 @@
+LOGICAL(LGT) :: isok, abool
+INTEGER(I4B) :: ii
+
+isok = ALLOCATED(A)
+
+IF (isok) THEN
+
+ abool = SIZE(A) .NE. nA
+
+ IF (abool) THEN
+ DEALLOCATE (A)
+ ALLOCATE (A(nA))
+ END IF
+
+ELSE
+
+ ALLOCATE (A(nA))
+
+END IF
+
+DO CONCURRENT(ii=1:nA)
+ A(ii) = 0.0
+END DO
+
+isok = ALLOCATED(IA)
+
+IF (isok) THEN
+
+ abool = SIZE(IA) .NE. nIA
+
+ IF (abool) THEN
+ DEALLOCATE (IA)
+ ALLOCATE (IA(nIA))
+ END IF
+
+ELSE
+ ALLOCATE (IA(nIA))
+END IF
+
+DO CONCURRENT(ii=1:nIA)
+ IA(ii) = 0
+END DO
diff --git a/src/submodules/Utility/src/Reallocate/reallocate2.F90 b/src/submodules/Utility/src/Reallocate/reallocate2.F90
new file mode 100644
index 000000000..570150ba5
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate2.F90
@@ -0,0 +1,66 @@
+LOGICAL :: isok, abool, ex, acase
+INTEGER(I4B) :: s(2), ii, jj, fac
+
+ex = .FALSE.
+IF (PRESENT(isExpand)) ex = isExpand
+
+fac = 1
+IF (PRESENT(expandFactor)) fac = expandFactor
+
+isok = ALLOCATED(mat)
+
+acase = isok .AND. (.NOT. ex)
+
+IF (acase) THEN
+
+ s = SHAPE(mat)
+
+ abool = s(1) .NE. row .OR. s(2) .NE. col
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(row, col))
+ END IF
+
+ DO CONCURRENT(ii=1:row, jj=1:col)
+ mat(ii, jj) = ZEROVALUE
+ END DO
+ RETURN
+
+END IF
+
+acase = isok .AND. ex
+
+IF (acase) THEN
+
+ s = SHAPE(mat)
+
+ abool = (s(1) .LT. row) .OR. &
+ (s(2) .LT. col)
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(row * fac, col * fac))
+ END IF
+
+ DO CONCURRENT(ii=1:row, jj=1:col)
+ mat(ii, jj) = ZEROVALUE
+ END DO
+ RETURN
+
+END IF
+
+ALLOCATE (mat(row * fac, col * fac))
+
+DO CONCURRENT(ii=1:row, jj=1:col)
+ mat(ii, jj) = ZEROVALUE
+END DO
+
+! IF (ALLOCATED(mat)) THEN
+! IF ((SIZE(mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
+! DEALLOCATE (mat)
+! ALLOCATE (mat(row, col))
+! END IF
+! ELSE
+! ALLOCATE (mat(row, col))
+! END IF
diff --git a/src/submodules/Utility/src/Reallocate/reallocate3.F90 b/src/submodules/Utility/src/Reallocate/reallocate3.F90
new file mode 100644
index 000000000..cf5b6380e
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate3.F90
@@ -0,0 +1,25 @@
+LOGICAL :: isok, abool
+INTEGER(I4B) :: s(3), ii, jj, kk
+
+isok = ALLOCATED(mat)
+
+IF (isok) THEN
+
+ s = SHAPE(mat)
+
+ abool = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(i1, i2, i3))
+ END IF
+
+ELSE
+
+ ALLOCATE (mat(i1, i2, i3))
+
+END IF
+
+DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3)
+ mat(ii, jj, kk) = ZEROVALUE
+END DO
diff --git a/src/submodules/Utility/src/Reallocate/reallocate4.F90 b/src/submodules/Utility/src/Reallocate/reallocate4.F90
new file mode 100644
index 000000000..52ca3200a
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate4.F90
@@ -0,0 +1,25 @@
+LOGICAL :: isok, abool
+INTEGER(I4B) :: s(4), ii, jj, kk, ll
+
+isok = ALLOCATED(mat)
+
+IF (isok) THEN
+
+ s = SHAPE(mat)
+
+ abool = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3 .OR. s(4) .NE. i4
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(i1, i2, i3, i4))
+ END IF
+
+ELSE
+
+ ALLOCATE (mat(i1, i2, i3, i4))
+
+END IF
+
+DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4)
+ mat(ii, jj, kk, ll) = ZEROVALUE
+END DO
diff --git a/src/submodules/Utility/src/Reallocate/reallocate5.F90 b/src/submodules/Utility/src/Reallocate/reallocate5.F90
new file mode 100644
index 000000000..9b373357a
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate5.F90
@@ -0,0 +1,29 @@
+LOGICAL :: isok, abool
+INTEGER(I4B) :: s(5), ii, jj, kk, ll, mm
+
+isok = ALLOCATED(mat)
+
+IF (isok) THEN
+
+ s = SHAPE(mat)
+
+ abool = (s(1) .NE. i1) .OR. &
+ (s(2) .NE. i2) .OR. &
+ s(3) .NE. i3 .OR. &
+ s(4) .NE. i4 .OR. &
+ s(5) .NE. i5
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(i1, i2, i3, i4, i5))
+ END IF
+
+ELSE
+
+ ALLOCATE (mat(i1, i2, i3, i4, i5))
+
+END IF
+
+DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4, mm=1:i5)
+ mat(ii, jj, kk, ll, mm) = ZEROVALUE
+END DO
diff --git a/src/submodules/Utility/src/Reallocate/reallocate6.F90 b/src/submodules/Utility/src/Reallocate/reallocate6.F90
new file mode 100644
index 000000000..596eb4be7
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate6.F90
@@ -0,0 +1,30 @@
+LOGICAL :: isok, abool
+INTEGER(I4B) :: s(6), ii, jj, kk, ll, mm, nn
+
+isok = ALLOCATED(mat)
+
+IF (isok) THEN
+
+ s = SHAPE(mat)
+
+ abool = (s(1) .NE. i1) .OR. &
+ (s(2) .NE. i2) .OR. &
+ s(3) .NE. i3 .OR. &
+ s(4) .NE. i4 .OR. &
+ s(5) .NE. i5 .OR. &
+ s(6) .NE. i6
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(i1, i2, i3, i4, i5, i6))
+ END IF
+
+ELSE
+
+ ALLOCATE (mat(i1, i2, i3, i4, i5, i6))
+
+END IF
+
+DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4, mm=1:i5, nn=1:i6)
+ mat(ii, jj, kk, ll, mm, nn) = ZEROVALUE
+END DO
diff --git a/src/submodules/Utility/src/Reallocate/reallocate7.F90 b/src/submodules/Utility/src/Reallocate/reallocate7.F90
new file mode 100644
index 000000000..ebbc04acf
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate7.F90
@@ -0,0 +1,31 @@
+LOGICAL :: isok, abool
+INTEGER(I4B) :: s(7), ii, jj, kk, ll, mm, nn, oo
+
+isok = ALLOCATED(mat)
+
+IF (isok) THEN
+
+ s = SHAPE(mat)
+
+ abool = (s(1) .NE. i1) .OR. &
+ (s(2) .NE. i2) .OR. &
+ (s(3) .NE. i3) .OR. &
+ (s(4) .NE. i4) .OR. &
+ (s(5) .NE. i5) .OR. &
+ (s(6) .NE. i6) .OR. &
+ (s(7) .NE. i7)
+
+ IF (abool) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(i1, i2, i3, i4, i5, i6, i7))
+ END IF
+
+ELSE
+
+ ALLOCATE (mat(i1, i2, i3, i4, i5, i6, i7))
+
+END IF
+
+DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3, ll=1:i4, mm=1:i5, nn=1:i6, oo=1:i7)
+ mat(ii, jj, kk, ll, mm, nn, oo) = ZEROVALUE
+END DO
diff --git a/src/submodules/Utility/src/Reallocate/reallocate8.F90 b/src/submodules/Utility/src/Reallocate/reallocate8.F90
new file mode 100644
index 000000000..60cf9b2c9
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate8.F90
@@ -0,0 +1,160 @@
+LOGICAL(LGT) :: isok, abool, ispresent
+INTEGER(I4B) :: ii
+
+isok = ALLOCATED(vec1)
+
+IF (isok) THEN
+
+ abool = SIZE(Vec1) .NE. n1
+
+ IF (abool) THEN
+ DEALLOCATE (Vec1)
+ ALLOCATE (Vec1(n1))
+ END IF
+
+ELSE
+ ALLOCATE (Vec1(n1))
+END IF
+
+DO CONCURRENT(ii=1:n1)
+ vec1(ii) = ZERO1
+END DO
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+isok = ALLOCATED(vec2)
+
+IF (isok) THEN
+
+ abool = SIZE(Vec2) .NE. n2
+
+ IF (abool) THEN
+ DEALLOCATE (Vec2)
+ ALLOCATE (Vec2(n2))
+ END IF
+
+ELSE
+ ALLOCATE (Vec2(n2))
+END IF
+
+DO CONCURRENT(ii=1:n2)
+ vec2(ii) = ZERO2
+END DO
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+ispresent = PRESENT(vec3)
+
+IF (ispresent) THEN
+
+ isok = ALLOCATED(vec3)
+
+ IF (isok) THEN
+
+ abool = SIZE(Vec3) .NE. n3
+
+ IF (abool) THEN
+ DEALLOCATE (Vec3)
+ ALLOCATE (Vec3(n3))
+ END IF
+
+ ELSE
+ ALLOCATE (Vec3(n3))
+ END IF
+
+ DO CONCURRENT(ii=1:n3)
+ vec3(ii) = ZERO3
+ END DO
+
+END IF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+ispresent = PRESENT(vec4)
+
+IF (ispresent) THEN
+
+ isok = ALLOCATED(vec4)
+
+ IF (isok) THEN
+
+ abool = SIZE(Vec4) .NE. n4
+
+ IF (abool) THEN
+ DEALLOCATE (Vec4)
+ ALLOCATE (Vec4(n4))
+ END IF
+
+ ELSE
+ ALLOCATE (Vec4(n4))
+ END IF
+
+ DO CONCURRENT(ii=1:n4)
+ vec4(ii) = ZERO4
+ END DO
+
+END IF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+ispresent = PRESENT(vec5)
+
+IF (ispresent) THEN
+
+ isok = ALLOCATED(vec5)
+
+ IF (isok) THEN
+
+ abool = SIZE(Vec5) .NE. n5
+
+ IF (abool) THEN
+ DEALLOCATE (Vec5)
+ ALLOCATE (Vec5(n5))
+ END IF
+
+ ELSE
+ ALLOCATE (Vec5(n5))
+ END IF
+
+ DO CONCURRENT(ii=1:n5)
+ vec5(ii) = ZERO5
+ END DO
+
+END IF
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+ispresent = PRESENT(vec6)
+
+IF (ispresent) THEN
+
+ isok = ALLOCATED(vec6)
+
+ IF (isok) THEN
+
+ abool = SIZE(Vec6) .NE. n6
+
+ IF (abool) THEN
+ DEALLOCATE (Vec6)
+ ALLOCATE (Vec6(n6))
+ END IF
+
+ ELSE
+ ALLOCATE (Vec6(n6))
+ END IF
+
+ DO CONCURRENT(ii=1:n6)
+ vec6(ii) = ZERO6
+ END DO
+
+END IF
diff --git a/src/submodules/Utility/src/Reallocate/reallocate9.F90 b/src/submodules/Utility/src/Reallocate/reallocate9.F90
new file mode 100644
index 000000000..5e0927306
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate9.F90
@@ -0,0 +1,61 @@
+LOGICAL(LGT) :: isok, abool
+INTEGER(I4B) :: ii
+
+isok = ALLOCATED(A)
+
+IF (isok) THEN
+
+ abool = SIZE(A) .NE. nA
+
+ IF (abool) THEN
+ DEALLOCATE (A)
+ ALLOCATE (A(nA))
+ END IF
+
+ELSE
+
+ ALLOCATE (A(nA))
+
+END IF
+
+DO CONCURRENT(ii=1:nA)
+ A(ii) = 0.0
+END DO
+
+isok = ALLOCATED(IA)
+
+IF (isok) THEN
+
+ abool = SIZE(IA) .NE. nIA
+
+ IF (abool) THEN
+ DEALLOCATE (IA)
+ ALLOCATE (IA(nIA))
+ END IF
+
+ELSE
+ ALLOCATE (IA(nIA))
+END IF
+
+DO CONCURRENT(ii=1:nIA)
+ IA(ii) = 0
+END DO
+
+isok = ALLOCATED(JA)
+
+IF (isok) THEN
+
+ abool = SIZE(JA) .NE. nJA
+
+ IF (abool) THEN
+ DEALLOCATE (JA)
+ ALLOCATE (JA(nJA))
+ END IF
+
+ELSE
+ ALLOCATE (JA(nJA))
+END IF
+
+DO CONCURRENT(ii=1:nJA)
+ JA(ii) = 0
+END DO
diff --git a/src/submodules/Utility/src/ReallocateUtility@Methods.F90 b/src/submodules/Utility/src/ReallocateUtility@Methods.F90
index a468f09db..2e4a87c96 100644
--- a/src/submodules/Utility/src/ReallocateUtility@Methods.F90
+++ b/src/submodules/Utility/src/ReallocateUtility@Methods.F90
@@ -20,7 +20,6 @@
! summary: Methods for reallocating arrays
SUBMODULE(ReallocateUtility) Methods
-USE BaseMethod
IMPLICIT NONE
CONTAINS
@@ -29,15 +28,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_logical
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = .FALSE.
+#define ZEROVALUE .FALSE.
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_logical
!----------------------------------------------------------------------------
@@ -45,15 +38,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R1
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = 0.0_DFP
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R1
!----------------------------------------------------------------------------
@@ -61,7 +48,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R1b
-CALL Reallocate_Real64_R1(mat, s(1))
+CALL Reallocate_Real64_R1(mat, s(1), isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R1b
!----------------------------------------------------------------------------
@@ -69,15 +56,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R1
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R1
!----------------------------------------------------------------------------
@@ -85,7 +66,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R1b
-CALL Reallocate_Real32_R1(mat, s(1))
+CALL Reallocate_Real32_R1(mat, s(1), isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R1b
!----------------------------------------------------------------------------
@@ -93,15 +74,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R2
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row, col))
- END IF
-ELSE
- ALLOCATE (Mat(row, col))
-END IF
-Mat = 0.0_DFP
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate2.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R2
!----------------------------------------------------------------------------
@@ -109,7 +84,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R2b
-CALL Reallocate_Real64_R2(mat, s(1), s(2))
+CALL Reallocate_Real64_R2(mat, s(1), s(2), isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R2b
!----------------------------------------------------------------------------
@@ -117,15 +92,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R2
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row, col))
- END IF
-ELSE
- ALLOCATE (Mat(row, col))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate2.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R2
!----------------------------------------------------------------------------
@@ -133,7 +102,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R2b
-CALL Reallocate_Real32_R2(mat, s(1), s(2))
+CALL Reallocate_Real32_R2(mat, s(1), s(2), isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R2b
!---------------------------------------------------------------------------
@@ -141,17 +110,9 @@
!---------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R3
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3))
-END IF
-Mat = 0.0_DFP
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate3.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R3
!----------------------------------------------------------------------------
@@ -159,7 +120,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R3b
-CALL Reallocate_Real64_R3(mat, s(1), s(2), s(3))
+CALL Reallocate_Real64_R3(mat, s(1), s(2), s(3), isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R3b
!---------------------------------------------------------------------------
@@ -167,17 +128,9 @@
!---------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R3
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate3.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R3
!----------------------------------------------------------------------------
@@ -185,7 +138,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R3b
-CALL Reallocate_Real32_R3(mat, s(1), s(2), s(3))
+CALL Reallocate_Real32_R3(mat, s(1), s(2), s(3), isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R3b
!----------------------------------------------------------------------------
@@ -193,19 +146,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R4
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3) &
- & .OR. (SIZE(Mat, 4) .NE. i4) &
- & ) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate4.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R4
!----------------------------------------------------------------------------
@@ -213,7 +156,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R4b
-CALL Reallocate_Real64_R4(mat, s(1), s(2), s(3), s(4))
+CALL Reallocate_Real64_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R4b
!----------------------------------------------------------------------------
@@ -221,19 +164,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R4
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3) &
- & .OR. (SIZE(Mat, 4) .NE. i4) &
- & ) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate4.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R4
!----------------------------------------------------------------------------
@@ -241,7 +174,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R4b
-CALL Reallocate_Real32_R4(mat, s(1), s(2), s(3), s(4))
+CALL Reallocate_Real32_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R4b
!----------------------------------------------------------------------------
@@ -249,15 +182,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R5
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate5.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R5
!----------------------------------------------------------------------------
@@ -265,7 +192,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R5b
-CALL Reallocate_Real64_R5(mat, s(1), s(2), s(3), s(4), s(5))
+CALL Reallocate_Real64_R5(mat, s(1), s(2), s(3), s(4), s(5), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R5b
!----------------------------------------------------------------------------
@@ -273,15 +201,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R5
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate5.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R5
!----------------------------------------------------------------------------
@@ -289,7 +211,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R5b
-CALL Reallocate_Real32_R5(mat, s(1), s(2), s(3), s(4), s(5))
+CALL Reallocate_Real32_R5(mat, s(1), s(2), s(3), s(4), s(5), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R5b
!----------------------------------------------------------------------------
@@ -297,15 +220,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R6
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate6.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R6
!----------------------------------------------------------------------------
@@ -313,7 +230,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R6b
-CALL Reallocate_Real64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6))
+CALL Reallocate_Real64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R6b
!----------------------------------------------------------------------------
@@ -321,15 +239,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R6
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate6.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R6
!----------------------------------------------------------------------------
@@ -337,7 +249,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R6b
-CALL Reallocate_Real32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6))
+CALL Reallocate_Real32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R6b
!----------------------------------------------------------------------------
@@ -345,15 +258,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R7
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real64
+#include "./Reallocate/reallocate7.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real64_R7
!----------------------------------------------------------------------------
@@ -361,7 +268,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R7b
-CALL Reallocate_Real64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7))
+CALL Reallocate_Real64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Real64_R7b
!----------------------------------------------------------------------------
@@ -369,15 +277,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R7
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
-END IF
-Mat = 0.0
+#define ZEROVALUE 0.0_Real32
+#include "./Reallocate/reallocate7.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Real32_R7
!----------------------------------------------------------------------------
@@ -385,7 +287,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R7b
-CALL Reallocate_Real32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7))
+CALL Reallocate_Real32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Real32_R7b
!----------------------------------------------------------------------------
@@ -393,15 +296,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R1
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int64
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R1
!----------------------------------------------------------------------------
@@ -409,7 +306,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R1b
-CALL Reallocate_Int64_R1(mat, s(1))
+CALL Reallocate_Int64_R1(mat, s(1), isExpand, expandFactor)
END PROCEDURE Reallocate_Int64_R1b
!----------------------------------------------------------------------------
@@ -417,15 +314,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R1
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int32
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R1
!----------------------------------------------------------------------------
@@ -433,7 +324,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R1b
-CALL Reallocate_Int32_R1(mat, s(1))
+CALL Reallocate_Int32_R1(mat, s(1), isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R1b
!----------------------------------------------------------------------------
@@ -441,15 +332,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int16_R1
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int16
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int16_R1
!----------------------------------------------------------------------------
@@ -457,7 +342,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int16_R1b
-CALL Reallocate_Int16_R1(mat, s(1))
+CALL Reallocate_Int16_R1(mat, s(1), isExpand, expandFactor)
END PROCEDURE Reallocate_Int16_R1b
!----------------------------------------------------------------------------
@@ -465,15 +350,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int8_R1
-IF (ALLOCATED(Mat)) THEN
- IF (SIZE(Mat) .NE. row) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row))
- END IF
-ELSE
- ALLOCATE (Mat(row))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int8
+#include "./Reallocate/reallocate1.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int8_R1
!----------------------------------------------------------------------------
@@ -481,7 +360,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int8_R1b
-CALL Reallocate_Int8_R1(mat, s(1))
+CALL Reallocate_Int8_R1(mat, s(1), isExpand, expandFactor)
END PROCEDURE Reallocate_Int8_R1b
!----------------------------------------------------------------------------
@@ -489,15 +368,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R2
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row, col))
- END IF
-ELSE
- ALLOCATE (Mat(row, col))
-END IF
-Mat = 0_DFP
+#define ZEROVALUE 0_Int64
+#include "./Reallocate/reallocate2.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R2
!----------------------------------------------------------------------------
@@ -505,7 +378,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R2b
-CALL Reallocate_Int64_R2(mat, s(1), s(2))
+CALL Reallocate_Int64_R2(mat, s(1), s(2), isExpand, expandFactor)
END PROCEDURE Reallocate_Int64_R2b
!----------------------------------------------------------------------------
@@ -513,15 +386,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R2
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row, col))
- END IF
-ELSE
- ALLOCATE (Mat(row, col))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int32
+#include "./Reallocate/reallocate2.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R2
!----------------------------------------------------------------------------
@@ -529,7 +396,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R2b
-CALL Reallocate_Int32_R2(mat, s(1), s(2))
+CALL Reallocate_Int32_R2(mat, s(1), s(2), isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R2b
!----------------------------------------------------------------------------
@@ -537,15 +404,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int16_R2
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row, col))
- END IF
-ELSE
- ALLOCATE (Mat(row, col))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int16
+#include "./Reallocate/reallocate2.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int16_R2
!----------------------------------------------------------------------------
@@ -553,7 +414,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int16_R2b
-CALL Reallocate_Int16_R2(mat, s(1), s(2))
+CALL Reallocate_Int16_R2(mat, s(1), s(2), isExpand, expandFactor)
END PROCEDURE Reallocate_Int16_R2b
!----------------------------------------------------------------------------
@@ -561,15 +422,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int8_R2
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. row) .OR. (SIZE(Mat, 2) .NE. col)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(row, col))
- END IF
-ELSE
- ALLOCATE (Mat(row, col))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int8
+#include "./Reallocate/reallocate2.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int8_R2
!----------------------------------------------------------------------------
@@ -577,7 +432,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int8_R2b
-CALL Reallocate_Int8_R2(mat, s(1), s(2))
+CALL Reallocate_Int8_R2(mat, s(1), s(2), isExpand, expandFactor)
END PROCEDURE Reallocate_Int8_R2b
!---------------------------------------------------------------------------
@@ -585,17 +440,9 @@
!---------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R3
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3))
-END IF
-Mat = 0_DFP
+#define ZEROVALUE 0_Int64
+#include "./Reallocate/reallocate3.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R3
!----------------------------------------------------------------------------
@@ -603,7 +450,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R3b
-CALL Reallocate_Int64_R3(mat, s(1), s(2), s(3))
+CALL Reallocate_Int64_R3(mat, s(1), s(2), s(3), isExpand, expandFactor)
END PROCEDURE Reallocate_Int64_R3b
!---------------------------------------------------------------------------
@@ -611,17 +458,9 @@
!---------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R3
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3)) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int32
+#include "./Reallocate/reallocate3.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R3
!----------------------------------------------------------------------------
@@ -629,7 +468,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R3b
-CALL Reallocate_Int32_R3(mat, s(1), s(2), s(3))
+CALL Reallocate_Int32_R3(mat, s(1), s(2), s(3), isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R3b
!----------------------------------------------------------------------------
@@ -637,19 +476,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R4
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3) &
- & .OR. (SIZE(Mat, 4) .NE. i4) &
- & ) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int64
+#include "./Reallocate/reallocate4.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R4
!----------------------------------------------------------------------------
@@ -657,7 +486,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R4b
-CALL Reallocate_Int64_R4(mat, s(1), s(2), s(3), s(4))
+CALL Reallocate_Int64_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor)
END PROCEDURE Reallocate_Int64_R4b
!----------------------------------------------------------------------------
@@ -665,19 +494,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R4
-IF (ALLOCATED(Mat)) THEN
- IF ((SIZE(Mat, 1) .NE. i1) &
- & .OR. (SIZE(Mat, 2) .NE. i2) &
- & .OR. (SIZE(Mat, 3) .NE. i3) &
- & .OR. (SIZE(Mat, 4) .NE. i4) &
- & ) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int32
+#include "./Reallocate/reallocate4.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R4
!----------------------------------------------------------------------------
@@ -685,7 +504,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R4b
-CALL Reallocate_Int32_R4(mat, s(1), s(2), s(3), s(4))
+CALL Reallocate_Int32_R4(mat, s(1), s(2), s(3), s(4), isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R4b
!----------------------------------------------------------------------------
@@ -693,15 +512,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R5
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int64
+#include "./Reallocate/reallocate5.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R5
!----------------------------------------------------------------------------
@@ -709,7 +522,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R5b
-CALL Reallocate_Int64_R5(mat, s(1), s(2), s(3), s(4), s(5))
+CALL Reallocate_Int64_R5(mat, s(1), s(2), s(3), s(4), s(5), isExpand, &
+ expandFactor)
END PROCEDURE Reallocate_Int64_R5b
!----------------------------------------------------------------------------
@@ -717,15 +531,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R5
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5))
-END IF
-Mat = 0
+#define ZEROVALUE 0_Int32
+#include "./Reallocate/reallocate5.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R5
!----------------------------------------------------------------------------
@@ -733,7 +541,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R5b
-CALL Reallocate_Int32_R5(mat, s(1), s(2), s(3), s(4), s(5))
+CALL Reallocate_Int32_R5(mat, s(1), s(2), s(3), s(4), s(5), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R5b
!----------------------------------------------------------------------------
@@ -741,15 +550,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R6
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
-END IF
-Mat = 0
+#define ZEROVALUE 0.0_Int64
+#include "./Reallocate/reallocate6.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R6
!----------------------------------------------------------------------------
@@ -757,7 +560,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R6b
-CALL Reallocate_Int64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6))
+CALL Reallocate_Int64_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Int64_R6b
!----------------------------------------------------------------------------
@@ -765,15 +569,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R6
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6))
-END IF
-Mat = 0
+#define ZEROVALUE 0.0_Int32
+#include "./Reallocate/reallocate6.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R6
!----------------------------------------------------------------------------
@@ -781,7 +579,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R6b
-CALL Reallocate_Int32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6))
+CALL Reallocate_Int32_R6(mat, s(1), s(2), s(3), s(4), s(5), s(6), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R6b
!----------------------------------------------------------------------------
@@ -789,15 +588,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R7
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
-END IF
-Mat = 0
+#define ZEROVALUE 0.0_Int64
+#include "./Reallocate/reallocate7.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int64_R7
!----------------------------------------------------------------------------
@@ -805,7 +598,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int64_R7b
-CALL Reallocate_Int64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7))
+CALL Reallocate_Int64_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Int64_R7b
!----------------------------------------------------------------------------
@@ -813,15 +607,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R7
-IF (ALLOCATED(Mat)) THEN
- IF (ANY(SHAPE(Mat) .NE. [i1, i2, i3, i4, i5, i6, i7])) THEN
- DEALLOCATE (Mat)
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
- END IF
-ELSE
- ALLOCATE (Mat(i1, i2, i3, i4, i5, i6, i7))
-END IF
-Mat = 0
+#define ZEROVALUE 0.0_Int32
+#include "./Reallocate/reallocate7.F90"
+#undef ZEROVALUE
END PROCEDURE Reallocate_Int32_R7
!----------------------------------------------------------------------------
@@ -829,7 +617,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R7b
-CALL Reallocate_Int32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7))
+CALL Reallocate_Int32_R7(mat, s(1), s(2), s(3), s(4), s(5), s(6), s(7), &
+ isExpand, expandFactor)
END PROCEDURE Reallocate_Int32_R7b
!----------------------------------------------------------------------------
@@ -837,74 +626,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Int32_R1_6
-IF (ALLOCATED(Vec1)) THEN
- IF (SIZE(Vec1) .NE. n1) THEN
- DEALLOCATE (Vec1)
- ALLOCATE (Vec1(n1))
- END IF
-ELSE
- ALLOCATE (Vec1(n1))
-END IF
-Vec1 = 0
-
-IF (ALLOCATED(Vec2)) THEN
- IF (SIZE(Vec2) .NE. n2) THEN
- DEALLOCATE (Vec2)
- ALLOCATE (Vec2(n2))
- END IF
-ELSE
- ALLOCATE (Vec2(n2))
-END IF
-Vec2 = 0
-
-IF (PRESENT(Vec3)) THEN
- IF (ALLOCATED(Vec3)) THEN
- IF (SIZE(Vec3) .NE. n3) THEN
- DEALLOCATE (Vec3)
- ALLOCATE (Vec3(n3))
- END IF
- ELSE
- ALLOCATE (Vec3(n3))
- END IF
- Vec3 = 0
-END IF
-
-IF (PRESENT(Vec4)) THEN
- IF (ALLOCATED(Vec4)) THEN
- IF (SIZE(Vec4) .NE. n4) THEN
- DEALLOCATE (Vec4)
- ALLOCATE (Vec4(n4))
- END IF
- ELSE
- ALLOCATE (Vec4(n4))
- END IF
- Vec4 = 0
-END IF
-
-IF (PRESENT(Vec5)) THEN
- IF (ALLOCATED(Vec5)) THEN
- IF (SIZE(Vec5) .NE. n5) THEN
- DEALLOCATE (Vec5)
- ALLOCATE (Vec5(n5))
- END IF
- ELSE
- ALLOCATE (Vec5(n5))
- END IF
- Vec5 = 0
-END IF
-
-IF (PRESENT(Vec6)) THEN
- IF (ALLOCATED(Vec6)) THEN
- IF (SIZE(Vec6) .NE. n6) THEN
- DEALLOCATE (Vec6)
- ALLOCATE (Vec6(n6))
- END IF
- ELSE
- ALLOCATE (Vec6(n6))
- END IF
- Vec6 = 0
-END IF
-
+#define ZERO1 0_I4B
+#define ZERO2 0_I4B
+#define ZERO3 0_I4B
+#define ZERO4 0_I4B
+#define ZERO5 0_I4B
+#define ZERO6 0_I4B
+#include "./Reallocate/reallocate8.F90"
+#undef ZERO1
+#undef ZERO2
+#undef ZERO3
+#undef ZERO4
+#undef ZERO5
+#undef ZERO6
END PROCEDURE Reallocate_Int32_R1_6
!----------------------------------------------------------------------------
@@ -912,73 +646,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_R1_6
-IF (ALLOCATED(Vec1)) THEN
- IF (SIZE(Vec1) .NE. n1) THEN
- DEALLOCATE (Vec1)
- ALLOCATE (Vec1(n1))
- END IF
-ELSE
- ALLOCATE (Vec1(n1))
-END IF
-Vec1 = 0.0
-
-IF (ALLOCATED(Vec2)) THEN
- IF (SIZE(Vec2) .NE. n2) THEN
- DEALLOCATE (Vec2)
- ALLOCATE (Vec2(n2))
- END IF
-ELSE
- ALLOCATE (Vec2(n2))
-END IF
-Vec2 = 0.0
-
-IF (PRESENT(Vec3)) THEN
- IF (ALLOCATED(Vec3)) THEN
- IF (SIZE(Vec3) .NE. n3) THEN
- DEALLOCATE (Vec3)
- ALLOCATE (Vec3(n3))
- END IF
- ELSE
- ALLOCATE (Vec3(n3))
- END IF
- Vec3 = 0.0
-END IF
-
-IF (PRESENT(Vec4)) THEN
- IF (ALLOCATED(Vec4)) THEN
- IF (SIZE(Vec4) .NE. n4) THEN
- DEALLOCATE (Vec4)
- ALLOCATE (Vec4(n4))
- END IF
- ELSE
- ALLOCATE (Vec4(n4))
- END IF
- Vec4 = 0.0
-END IF
-
-IF (PRESENT(Vec5)) THEN
- IF (ALLOCATED(Vec5)) THEN
- IF (SIZE(Vec5) .NE. n5) THEN
- DEALLOCATE (Vec5)
- ALLOCATE (Vec5(n5))
- END IF
- ELSE
- ALLOCATE (Vec5(n5))
- END IF
- Vec5 = 0.0
-END IF
-
-IF (PRESENT(Vec6)) THEN
- IF (ALLOCATED(Vec6)) THEN
- IF (SIZE(Vec6) .NE. n6) THEN
- DEALLOCATE (Vec6)
- ALLOCATE (Vec6(n6))
- END IF
- ELSE
- ALLOCATE (Vec6(n6))
- END IF
- Vec6 = 0.0
-END IF
+#define ZERO1 0.0_Real64
+#define ZERO2 0.0_Real64
+#define ZERO3 0.0_Real64
+#define ZERO4 0.0_Real64
+#define ZERO5 0.0_Real64
+#define ZERO6 0.0_Real64
+#include "./Reallocate/reallocate8.F90"
+#undef ZERO1
+#undef ZERO2
+#undef ZERO3
+#undef ZERO4
+#undef ZERO5
+#undef ZERO6
END PROCEDURE Reallocate_Real64_R1_6
!----------------------------------------------------------------------------
@@ -986,73 +666,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_R1_6
-IF (ALLOCATED(Vec1)) THEN
- IF (SIZE(Vec1) .NE. n1) THEN
- DEALLOCATE (Vec1)
- ALLOCATE (Vec1(n1))
- END IF
-ELSE
- ALLOCATE (Vec1(n1))
-END IF
-Vec1 = 0.0
-
-IF (ALLOCATED(Vec2)) THEN
- IF (SIZE(Vec2) .NE. n2) THEN
- DEALLOCATE (Vec2)
- ALLOCATE (Vec2(n2))
- END IF
-ELSE
- ALLOCATE (Vec2(n2))
-END IF
-Vec2 = 0.0
-
-IF (PRESENT(Vec3)) THEN
- IF (ALLOCATED(Vec3)) THEN
- IF (SIZE(Vec3) .NE. n3) THEN
- DEALLOCATE (Vec3)
- ALLOCATE (Vec3(n3))
- END IF
- ELSE
- ALLOCATE (Vec3(n3))
- END IF
- Vec3 = 0.0
-END IF
-
-IF (PRESENT(Vec4)) THEN
- IF (ALLOCATED(Vec4)) THEN
- IF (SIZE(Vec4) .NE. n4) THEN
- DEALLOCATE (Vec4)
- ALLOCATE (Vec4(n4))
- END IF
- ELSE
- ALLOCATE (Vec4(n4))
- END IF
- Vec4 = 0.0
-END IF
-
-IF (PRESENT(Vec5)) THEN
- IF (ALLOCATED(Vec5)) THEN
- IF (SIZE(Vec5) .NE. n5) THEN
- DEALLOCATE (Vec5)
- ALLOCATE (Vec5(n5))
- END IF
- ELSE
- ALLOCATE (Vec5(n5))
- END IF
- Vec5 = 0.0
-END IF
-
-IF (PRESENT(Vec6)) THEN
- IF (ALLOCATED(Vec6)) THEN
- IF (SIZE(Vec6) .NE. n6) THEN
- DEALLOCATE (Vec6)
- ALLOCATE (Vec6(n6))
- END IF
- ELSE
- ALLOCATE (Vec6(n6))
- END IF
- Vec6 = 0.0
-END IF
+#define ZERO1 0.0_Real32
+#define ZERO2 0.0_Real32
+#define ZERO3 0.0_Real32
+#define ZERO4 0.0_Real32
+#define ZERO5 0.0_Real32
+#define ZERO6 0.0_Real32
+#include "./Reallocate/reallocate8.F90"
+#undef ZERO1
+#undef ZERO2
+#undef ZERO3
+#undef ZERO4
+#undef ZERO5
+#undef ZERO6
END PROCEDURE Reallocate_Real32_R1_6
!----------------------------------------------------------------------------
@@ -1060,35 +686,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_AIJ
-IF (ALLOCATED(A)) THEN
- IF (SIZE(A) .NE. nA) THEN
- DEALLOCATE (A)
- ALLOCATE (A(nA))
- END IF
-ELSE
- ALLOCATE (A(nA))
-END IF
-A = 0.0
-
-IF (ALLOCATED(IA)) THEN
- IF (SIZE(IA) .NE. nIA) THEN
- DEALLOCATE (IA)
- ALLOCATE (IA(nIA))
- END IF
-ELSE
- ALLOCATE (IA(nIA))
-END IF
-IA = 0
-
-IF (ALLOCATED(JA)) THEN
- IF (SIZE(JA) .NE. nJA) THEN
- DEALLOCATE (JA)
- ALLOCATE (JA(nJA))
- END IF
-ELSE
- ALLOCATE (JA(nJA))
-END IF
-JA = 0
+#include "./Reallocate/reallocate9.F90"
END PROCEDURE Reallocate_Real64_AIJ
!----------------------------------------------------------------------------
@@ -1096,35 +694,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_AIJ
-IF (ALLOCATED(A)) THEN
- IF (SIZE(A) .NE. nA) THEN
- DEALLOCATE (A)
- ALLOCATE (A(nA))
- END IF
-ELSE
- ALLOCATE (A(nA))
-END IF
-A = 0.0
-
-IF (ALLOCATED(IA)) THEN
- IF (SIZE(IA) .NE. nIA) THEN
- DEALLOCATE (IA)
- ALLOCATE (IA(nIA))
- END IF
-ELSE
- ALLOCATE (IA(nIA))
-END IF
-IA = 0
-
-IF (ALLOCATED(JA)) THEN
- IF (SIZE(JA) .NE. nJA) THEN
- DEALLOCATE (JA)
- ALLOCATE (JA(nJA))
- END IF
-ELSE
- ALLOCATE (JA(nJA))
-END IF
-JA = 0
+#include "./Reallocate/reallocate9.F90"
END PROCEDURE Reallocate_Real32_AIJ
!----------------------------------------------------------------------------
@@ -1132,25 +702,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real64_AI
-IF (ALLOCATED(A)) THEN
- IF (SIZE(A) .NE. nA) THEN
- DEALLOCATE (A)
- ALLOCATE (A(nA))
- END IF
-ELSE
- ALLOCATE (A(nA))
-END IF
-A = 0.0
-
-IF (ALLOCATED(IA)) THEN
- IF (SIZE(IA) .NE. nIA) THEN
- DEALLOCATE (IA)
- ALLOCATE (IA(nIA))
- END IF
-ELSE
- ALLOCATE (IA(nIA))
-END IF
-IA = 0
+#include "./Reallocate/reallocate10.F90"
END PROCEDURE Reallocate_Real64_AI
!----------------------------------------------------------------------------
@@ -1158,25 +710,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE Reallocate_Real32_AI
-IF (ALLOCATED(A)) THEN
- IF (SIZE(A) .NE. nA) THEN
- DEALLOCATE (A)
- ALLOCATE (A(nA))
- END IF
-ELSE
- ALLOCATE (A(nA))
-END IF
-A = 0.0
-
-IF (ALLOCATED(IA)) THEN
- IF (SIZE(IA) .NE. nIA) THEN
- DEALLOCATE (IA)
- ALLOCATE (IA(nIA))
- END IF
-ELSE
- ALLOCATE (IA(nIA))
-END IF
-IA = 0
+#include "./Reallocate/reallocate10.F90"
END PROCEDURE Reallocate_Real32_AI
!----------------------------------------------------------------------------
diff --git a/src/submodules/Utility/src/SortUtility@Methods.F90 b/src/submodules/Utility/src/SortUtility@Methods.F90
index e4e198cf1..8561b6c01 100644
--- a/src/submodules/Utility/src/SortUtility@Methods.F90
+++ b/src/submodules/Utility/src/SortUtility@Methods.F90
@@ -20,8 +20,16 @@
! summary: This submodule contains the sorting routine
SUBMODULE(SortUtility) Methods
-USE BaseMethod, ONLY: Swap, UpperCase, arange, Median, Partition, &
-& ArgPartition, ArgMedian
+USE SwapUtility, ONLY: Swap
+
+USE StringUtility, ONLY: UpperCase
+
+USE ArangeUtility, ONLY: Arange
+
+USE MedianUtility, ONLY: Median, ArgMedian
+
+USE PartitionUtility, ONLY: Partition, ArgPartition
+
IMPLICIT NONE
INTEGER(I4B), PARAMETER :: minimumLengthForInsertion = 16
diff --git a/src/submodules/Utility/src/StringUtility@Methods.F90 b/src/submodules/Utility/src/StringUtility@Methods.F90
index 593866362..4906fb4fe 100644
--- a/src/submodules/Utility/src/StringUtility@Methods.F90
+++ b/src/submodules/Utility/src/StringUtility@Methods.F90
@@ -16,10 +16,156 @@
!
SUBMODULE(StringUtility) Methods
+USE GlobalData, ONLY: CHAR_BSLASH, CHAR_DOT, CHAR_FSLASH, CHAR_SLASH
+
USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_END
+
IMPLICIT NONE
+
CONTAINS
+!----------------------------------------------------------------------------
+! PathDir
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE PathDir
+INTEGER(I4B) :: tsize, last
+INTEGER(I4B), ALLOCATABLE :: indices(:)
+
+ans = TRIM(path)
+tsize = LEN(ans)
+IF (tsize .EQ. 0) THEN
+ ans = "."
+ RETURN
+END IF
+
+IF ((tsize .EQ. 1)) THEN
+ IF (ans(1:1) .NE. CHAR_SLASH) THEN
+ ans = "."
+ END IF
+ RETURN
+END IF
+
+last = tsize
+DO
+ IF (ans(last:last) .EQ. CHAR_SLASH) THEN
+ last = last - 1
+ ans = ans(1:last)
+ ELSE
+ EXIT
+ END IF
+
+ IF (last .EQ. 1) EXIT
+END DO
+
+IF (last .EQ. 1) RETURN
+
+tsize = LEN(ans)
+
+CALL StrFind(chars=ans, pattern=CHAR_SLASH, indices=indices)
+
+! It means no / found in the path
+IF (SIZE(indices) .EQ. 0) THEN
+ ans = "."
+ DEALLOCATE (indices)
+ RETURN
+END IF
+
+last = indices(SIZE(indices)) - 1
+
+! /abc type pattern
+IF (last .EQ. 0) THEN
+ ans = "/"
+ DEALLOCATE (indices)
+ RETURN
+END IF
+
+ans = ans(1:last)
+DEALLOCATE (indices)
+
+DO
+ IF (last .EQ. 1) EXIT
+ IF (ans(last:last) .EQ. CHAR_SLASH) THEN
+ last = last - 1
+ ans = ans(1:last)
+ ELSE
+ EXIT
+ END IF
+
+END DO
+
+END PROCEDURE PathDir
+
+!----------------------------------------------------------------------------
+! PathBase
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE PathBase
+INTEGER(I4B) :: tsize, last
+INTEGER(I4B), ALLOCATABLE :: indices(:)
+
+ans = TRIM(path)
+
+tsize = LEN(ans)
+
+IF (tsize .EQ. 0) THEN
+ ans = "."
+ RETURN
+END IF
+
+IF ((tsize .EQ. 1)) RETURN
+
+last = tsize
+DO
+ IF (ans(last:last) .EQ. CHAR_SLASH) THEN
+ last = last - 1
+ ans = ans(1:last)
+ ELSE
+ EXIT
+ END IF
+
+ IF (last .EQ. 1) EXIT
+END DO
+
+IF (last .EQ. 1) RETURN
+
+tsize = LEN(ans)
+
+CALL StrFind(chars=ans, pattern=CHAR_SLASH, indices=indices)
+IF (SIZE(indices) .EQ. 0) THEN
+ last = 1
+ELSE
+ last = indices(SIZE(indices)) + 1
+END IF
+
+ans = ans(last:tsize)
+IF (ALLOCATED(indices)) DEALLOCATE (indices)
+END PROCEDURE PathBase
+
+!----------------------------------------------------------------------------
+! PathJoin
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE PathJoin1
+ans = TRIM(path1)//CHAR_SLASH//TRIM(path2)
+END PROCEDURE PathJoin1
+
+!----------------------------------------------------------------------------
+! PathJoin
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE PathJoin2
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(paths)
+ans = ""
+
+DO ii = 1, tsize
+ ans = ans//CHAR_SLASH//paths(ii)%chars()
+END DO
+
+END PROCEDURE PathJoin2
+
!----------------------------------------------------------------------------
! UpperCase
!----------------------------------------------------------------------------