diff --git a/.fortls b/.fortls
deleted file mode 100644
index 20162a203..000000000
--- a/.fortls
+++ /dev/null
@@ -1,28 +0,0 @@
-{
- "source_dirs": [
- "src/**"
- ],
- "excl_suffixes": [
- "_skip.F90",
- ".bk",
- ".ignore"
- ],
- "pp_suffixes": [
- ".F90",
- ".inc",
- ".part",
- ".f90"
- ],
- "pp_defs": {},
- "include_dirs": [],
- "ext_source_dirs": [],
- "lowercase_intrinsics": false,
- "debug_log": false,
- "disable_diagnostics": false,
- "sort_keywords": false,
- "use_signature_help": true,
- "hover_signature": true,
- "hover_language": "fortran",
- "enable_code_actions": false,
- "symbol_skip_mem": false
-}
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/fortitude.toml b/fortitude.toml
new file mode 100644
index 000000000..f3f158533
--- /dev/null
+++ b/fortitude.toml
@@ -0,0 +1,10 @@
+[check]
+preview = true
+select = ["C", "E", "S", "MOD", "OB"]
+# ignore = []
+file-extensions = ["f90", "F90"]
+line-length = 78
+fix = false
+# output-format = "full"
+# show-fixes = false
+# unsafe-fixes = true
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..ce28c82a9 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
+
+ astr = UpperCase(name(1:2))
- SELECT CASE (astr%chars())
+ 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
@@ -115,26 +129,44 @@ END SUBROUTINE BaseContinuity_Copy
! date: 2023-08-09
! summary: Returns a string name of base interpolation type
-FUNCTION BaseContinuity_ToString(obj) RESULT(ans)
+FUNCTION BaseContinuity_ToString(obj, isUpper) RESULT(ans)
CLASS(BaseContinuity_), INTENT(IN) :: obj
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
TYPE(String) :: ans
+
+ ! internal variables
+ LOGICAL(LGT) :: isUpper0
+
+ isUpper0 = .FALSE.
+ IF (PRESENT(isUpper)) isUpper0 = isUpper
+
SELECT TYPE (obj)
CLASS IS (H1_)
ans = "H1"
+
CLASS IS (HCurl_)
- ans = "HCurl"
+ IF (isUpper0) THEN
+ ans = "HCURL"
+ ELSE
+ ans = "HCurl"
+ END IF
+
CLASS IS (HDiv_)
- ans = "HDiv"
+ IF (isUpper0) THEN
+ ans = "HDIV"
+ ELSE
+ ans = "HDiv"
+ END IF
+
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 +179,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..4afe02b7f 100644
--- a/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90
+++ b/src/modules/BaseInterpolation/src/BaseInterpolation_Method.F90
@@ -18,29 +18,37 @@
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 :: BaseInterpolation_ToString
+PUBLIC :: BaseInterpolation_ToChar
-INTERFACE BaseInterpolation_ToInteger
- MODULE PROCEDURE BaseInterpolation_ToInteger1
- MODULE PROCEDURE BaseInterpolation_ToInteger2
-END INTERFACE BaseInterpolation_ToInteger
+PUBLIC :: BaseType_ToChar
+PUBLIC :: BaseType_ToInteger
-INTERFACE BaseInterpolation_ToString
- MODULE PROCEDURE BaseInterpolation_ToString1
- MODULE PROCEDURE BaseInterpolation_ToString2
-END INTERFACE BaseInterpolation_ToString
+PUBLIC :: InterpolationPoint_ToChar
+PUBLIC :: InterpolationPoint_ToString
+PUBLIC :: InterpolationPoint_ToInteger
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE BaseInterpolation_Copy
@@ -59,36 +67,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 +114,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_ToInteger(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_ToInteger
!----------------------------------------------------------------------------
-! 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_ToInteger(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_ToInteger()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
+
END SELECT
-END FUNCTION BaseInterpolation_ToInteger1
+END FUNCTION BaseType_ToInteger
!----------------------------------------------------------------------------
! BaseInterpolation_toInteger
@@ -204,246 +216,529 @@ END FUNCTION BaseInterpolation_ToInteger1
! date: 2023-08-09
! summary: Returns a string name of base interpolation type
-FUNCTION BaseInterpolation_ToInteger2(name) RESULT(ans)
+FUNCTION InterpolationPoint_ToInteger(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
-END FUNCTION BaseInterpolation_ToInteger2
+
+ astr = ""
+END FUNCTION InterpolationPoint_ToInteger
!----------------------------------------------------------------------------
-! 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
- CHARACTER(*), INTENT(IN) :: name
- TYPE(String) :: ans
-
- ans = UpperCase(name)
- IF (ALLOCATED(obj)) DEALLOCATE (obj)
+ INTEGER(I4B), INTENT(IN) :: name
- SELECT CASE (ans%chars())
- CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION")
+ SELECT CASE (name)
+ CASE (poly%lagrange)
ALLOCATE (LagrangeInterpolation_ :: obj)
- CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION")
+
+ CASE (poly%serendipity)
ALLOCATE (SerendipityInterpolation_ :: obj)
- CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION")
+
+ CASE (poly%hermit)
ALLOCATE (HermitInterpolation_ :: obj)
- CASE ( &
- & "HIERARCHICALPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHICALPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION")
- ALLOCATE (HierarchyInterpolation_ :: obj)
- CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION")
+
+ CASE (poly%orthogonal)
ALLOCATE (OrthogonalInterpolation_ :: obj)
+
+ CASE (poly%hierarchical)
+ ALLOCATE (HierarchyInterpolation_ :: 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 given name="//tostring(name), &
+ routine="BaseInterpolation_fromInteger()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
END SELECT
-END SUBROUTINE BaseInterpolation_FromString
+
+END SUBROUTINE BaseInterpolation_FromInteger
!----------------------------------------------------------------------------
-! BaseInterpolation_fromInteger
+! BaseInterpolation_fromString
!----------------------------------------------------------------------------
!> 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
- INTEGER(I4B), INTENT(IN) :: name
+SUBROUTINE BaseInterpolation_FromString(obj, name)
+ CLASS(BaseInterpolation_), ALLOCATABLE, INTENT(INOUT) :: obj
+ CHARACTER(*), INTENT(IN) :: name
- SELECT CASE (name)
- CASE (LagrangePolynomial)
+ CHARACTER(4) :: ans
+
+ ans = UpperCase(name(1:4))
+
+ IF (ALLOCATED(obj)) DEALLOCATE (obj)
+
+ SELECT CASE (ans)
+
+ CASE ("LAGR")
ALLOCATE (LagrangeInterpolation_ :: obj)
- CASE (SerendipityPolynomial)
+
+ CASE ("SERE")
ALLOCATE (SerendipityInterpolation_ :: obj)
- CASE (HermitPolynomial)
+
+ CASE ("HERM")
ALLOCATE (HermitInterpolation_ :: obj)
- CASE (OrthogonalPolynomial)
- ALLOCATE (OrthogonalInterpolation_ :: obj)
- CASE (HeirarchicalPolynomial)
+
+ CASE ("HIER", "HEIR")
ALLOCATE (HierarchyInterpolation_ :: obj)
+
+ CASE ("ORTH")
+ ALLOCATE (OrthogonalInterpolation_ :: obj)
+
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 type of name="//name, &
+ routine="BaseInterpolation_fromString()", &
+ line=__LINE__, unitno=stderr, file=__FILE__)
+ STOP
END SELECT
-END SUBROUTINE BaseInterpolation_FromInteger
+END SUBROUTINE BaseInterpolation_FromString
!----------------------------------------------------------------------------
-! QuadraturePointIDToName
+! BaseInterpolation_toString
!----------------------------------------------------------------------------
-FUNCTION BaseInterpolation_ToString2(name) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: name
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-09
+! summary: Returns a string name of base interpolation type
+
+FUNCTION BaseInterpolation_ToString(obj, isUpper) RESULT(ans)
+ CLASS(BaseInterpolation_), INTENT(IN) :: obj
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
TYPE(String) :: ans
+ ans = BaseInterpolation_ToChar(obj=obj, isUpper=isUpper)
+END FUNCTION BaseInterpolation_ToString
- SELECT CASE (name)
- CASE (Equidistance)
- ans = "EQUIDISTANCE"
+!----------------------------------------------------------------------------
+! BaseInterpolation_ToChar
+!----------------------------------------------------------------------------
- CASE (GaussLegendre)
- ans = "GAUSSLEGENDRE"
+FUNCTION BaseInterpolation_ToChar(obj, isUpper) RESULT(ans)
+ CLASS(BaseInterpolation_), INTENT(IN) :: obj
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
+ CHARACTER(:), ALLOCATABLE :: ans
- CASE (GaussLegendreLobatto)
- ans = "GAUSSLEGENDRELOBATTO"
+ ! internal variables
+ LOGICAL(LGT) :: isUpper0
- CASE (GaussLegendreRadau)
- ans = "GAUSSLEGENDRERADAU"
+ isUpper0 = .FALSE.
+ IF (PRESENT(isUpper)) isUpper0 = isUpper
- CASE (GaussLegendreRadauLeft)
- ans = "GAUSSLEGENDRERADAULEFT"
+ SELECT TYPE (obj)
+ CLASS IS (LagrangeInterpolation_)
+ IF (isUpper0) THEN
+ ans = "LAGRANGEINTERPOLATION"
+ ELSE
+ ans = "LagrangeInterpolation"
+ END IF
- CASE (GaussLegendreRadauRight)
- ans = "GAUSSLEGENDRERADAURIGHT"
+ CLASS IS (SerendipityInterpolation_)
+ IF (isUpper0) THEN
+ ans = "SERENDIPITYINTERPOLATION"
+ ELSE
+ ans = "SerendipityInterpolation"
+ END IF
- CASE (GaussChebyshev)
- ans = "GAUSSCHEBYSHEV"
+ CLASS IS (HermitInterpolation_)
+ IF (isUpper0) THEN
+ ans = "HERMITINTERPOLATION"
+ ELSE
+ ans = "HermitInterpolation"
+ END IF
- CASE (GaussChebyshevLobatto)
- ans = "GAUSSCHEBYSHEVLOBATTO"
+ CLASS IS (HierarchyInterpolation_)
+ IF (isUpper0) THEN
+ ans = "HIERARCHYINTERPOLATION"
+ ELSE
+ ans = "HierarchyInterpolation"
+ END IF
- CASE (GaussChebyshevRadau)
- ans = "GAUSSCHEBYSHEVRADAU"
+ CLASS IS (OrthogonalInterpolation_)
+ IF (isUpper0) THEN
+ ans = "ORTHOGONALINTERPOLATION"
+ ELSE
+ ans = "OrthogonalInterpolation"
+ END IF
- CASE (GaussChebyshevRadauLeft)
- ans = "GAUSSCHEBYSHEVRADAULEFT"
+ CLASS DEFAULT
+ ans = ""
+ CALL ErrorMsg(msg="No Case Found For Type of obj2", &
+ routine="BaseInterpolation_ToString()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
+ END SELECT
- CASE (GaussChebyshevRadauRight)
- ans = "GAUSSCHEBYSHEVRADAURIGHT"
+END FUNCTION BaseInterpolation_ToChar
- CASE (GaussJacobi)
- ans = "GAUSSJACOBI"
+!----------------------------------------------------------------------------
+! BaseType_ToChar
+!----------------------------------------------------------------------------
- CASE (GaussJacobiLobatto)
- ans = "GAUSSJACOBILOBATTO"
+FUNCTION BaseType_ToChar(name, isUpper) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
+ CHARACTER(:), ALLOCATABLE :: ans
- CASE (GaussJacobiRadau)
- ans = "GAUSSJACOBIRADAU"
+ ! internal variable
+ LOGICAL(LGT) :: isUpper0
- CASE (GaussJacobiRadauLeft)
- ans = "GAUSSJACOBIRADAULEFT"
+ isUpper0 = .FALSE.
+ IF (PRESENT(isUpper)) isUpper0 = isUpper
- CASE (GaussJacobiRadauRight)
- ans = "GAUSSJACOBIRADAURIGHT"
+ SELECT CASE (name)
+ CASE (poly%monomial)
+ IF (isUpper0) THEN
+ ans = "MONOMIAL"
+ ELSE
+ ans = "Monomial"
+ END IF
+
+ CASE (poly%lagrange)
+ IF (isUpper0) THEN
+ ans = "LAGRANGEINTERPOLATION"
+ ELSE
+ ans = "LagrangeInterpolation"
+ END IF
+
+ CASE (poly%serendipity)
+ IF (isUpper0) THEN
+ ans = "SERENDIPITYINTERPOLATION"
+ ELSE
+ ans = "SerendipityInterpolation"
+ END IF
+
+ CASE (poly%hermit)
+ IF (isUpper0) THEN
+ ans = "HERMITINTERPOLATION"
+ ELSE
+ ans = "HermitInterpolation"
+ END IF
+
+ CASE (poly%hierarchical)
+ IF (isUpper0) THEN
+ ans = "HIERARCHYINTERPOLATION"
+ ELSE
+ ans = "HierarchyInterpolation"
+ END IF
+
+ CASE (poly%orthogonal)
+ IF (isUpper0) THEN
+ ans = "ORTHOGONALINTERPOLATION"
+ ELSE
+ ans = "OrthogonalInterpolation"
+ END IF
+
+ CASE (poly%legendre)
+ IF (isUpper0) THEN
+ ans = "LEGENDREINTERPOLATION"
+ ELSE
+ ans = "LegendreInterpolation"
+ END IF
+
+ CASE (poly%jacobi)
+ IF (isUpper0) THEN
+ ans = "JACOBIINTERPOLATION"
+ ELSE
+ ans = "JacobiInterpolation"
+ END IF
+
+ CASE (poly%ultraspherical)
+ IF (isUpper0) THEN
+ ans = "ULTRASPHERICALINTERPOLATION"
+ ELSE
+ ans = "UltrasphericalInterpolation"
+ END IF
+
+ CASE (poly%chebyshev)
+ IF (isUpper0) THEN
+ ans = "CHEBYSHEVINTERPOLATION"
+ ELSE
+ ans = "ChebyshevInterpolation"
+ END IF
- CASE (GaussUltraspherical)
- ans = "GAUSSULTRASPHERICAL"
+ CASE DEFAULT
+ CALL ErrorMsg(msg="No Case Found For name "//tostring(name), &
+ routine="BaseType_ToChar()", &
+ line=__LINE__, unitno=stdout, file=__FILE__)
+ STOP
+ END SELECT
+
+END FUNCTION BaseType_ToChar
+
+!----------------------------------------------------------------------------
+! QuadraturePointIDToName
+!----------------------------------------------------------------------------
+
+FUNCTION InterpolationPoint_ToString(name, isUpper) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
+ TYPE(String) :: ans
+ ans = InterpolationPoint_ToChar(name=name, isUpper=isUpper)
+END FUNCTION InterpolationPoint_ToString
+
+!----------------------------------------------------------------------------
+! BaseInterpolation_ToChar
+!----------------------------------------------------------------------------
- CASE (GaussUltrasphericalLobatto)
- ans = "GAUSSULTRASPHERICALLOBATTO"
+FUNCTION InterpolationPoint_ToChar(name, isUpper) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
+ CHARACTER(:), ALLOCATABLE :: ans
- CASE (GaussUltrasphericalRadau)
- ans = "GAUSSULTRASPHERICALRADAU"
+ ! internal varibles
+ LOGICAL(LGT) :: isUpper0
- CASE (GaussUltrasphericalRadauLeft)
- ans = "GAUSSULTRASPHERICALRADAULEFT"
+ isUpper0 = .FALSE.
+ IF (PRESENT(isUpper)) isUpper0 = isUpper
- CASE (GaussUltrasphericalRadauRight)
- ans = "GAUSSULTRASPHERICALRADAURIGHT"
+ SELECT CASE (name)
+ CASE (ip%equidistance)
+ IF (isUpper0) THEN
+ ans = "EQUIDISTANCE"
+ ELSE
+ ans = "Equidistance"
+ END IF
+
+ CASE (ip%GaussLegendre)
+ IF (isUpper0) THEN
+ ans = "GAUSSLEGENDRE"
+ ELSE
+ ans = "GaussLegendre"
+ END IF
+
+ CASE (ip%GaussLegendreLobatto)
+ IF (isUpper0) THEN
+ ans = "GAUSSLEGENDRELOBATTO"
+ ELSE
+ ans = "GaussLegendreLobatto"
+ END IF
+
+ CASE (ip%GaussLegendreRadau)
+ IF (isUpper0) THEN
+ ans = "GAUSSLEGENDRERADAU"
+ ELSE
+ ans = "GaussLegendreRadau"
+ END IF
+
+ CASE (ip%GaussLegendreRadauLeft)
+ IF (isUpper0) THEN
+ ans = "GAUSSLEGENDRERADAULEFT"
+ ELSE
+ ans = "GaussLegendreRadauLeft"
+ END IF
+
+ CASE (ip%GaussLegendreRadauRight)
+ IF (isUpper0) THEN
+ ans = "GAUSSLEGENDRERADAURIGHT"
+ ELSE
+ ans = "GaussLegendreRadauRight"
+ END IF
+
+ CASE (ip%GaussChebyshev)
+ IF (isUpper0) THEN
+ ans = "GAUSSCHEBYSHEV"
+ ELSE
+ ans = "GaussChebyshev"
+ END IF
+
+ CASE (ip%GaussChebyshevLobatto)
+ IF (isUpper0) THEN
+ ans = "GAUSSCHEBYSHEVLOBATTO"
+ ELSE
+ ans = "GaussChebyshevLobatto"
+ END IF
+
+ CASE (ip%GaussChebyshevRadau)
+ IF (isUpper0) THEN
+ ans = "GAUSSCHEBYSHEVRADAU"
+ ELSE
+ ans = "GaussChebyshevRadau"
+ END IF
+
+ CASE (ip%GaussChebyshevRadauLeft)
+ IF (isUpper0) THEN
+ ans = "GAUSSCHEBYSHEVRADAULEFT"
+ ELSE
+ ans = "GaussChebyshevRadauLeft"
+ END IF
+
+ CASE (ip%GaussChebyshevRadauRight)
+ IF (isUpper0) THEN
+ ans = "GAUSSCHEBYSHEVRADAURIGHT"
+ ELSE
+ ans = "GaussChebyshevRadauRight"
+ END IF
+
+ CASE (ip%GaussJacobi)
+ IF (isUpper0) THEN
+ ans = "GAUSSJACOBI"
+ ELSE
+ ans = "GaussJacobi"
+ END IF
+
+ CASE (ip%GaussJacobiLobatto)
+ IF (isUpper0) THEN
+ ans = "GAUSSJACOBILOBATTO"
+ ELSE
+ ans = "GaussJacobiLobatto"
+ END IF
+
+ CASE (ip%GaussJacobiRadau)
+ IF (isUpper0) THEN
+ ans = "GAUSSJACOBIRADAU"
+ ELSE
+ ans = "GaussJacobiRadau"
+ END IF
+
+ CASE (ip%GaussJacobiRadauLeft)
+ IF (isUpper0) THEN
+ ans = "GAUSSJACOBIRADAULEFT"
+ ELSE
+ ans = "GaussJacobiRadauLeft"
+ END IF
+
+ CASE (ip%GaussJacobiRadauRight)
+ IF (isUpper0) THEN
+ ans = "GAUSSJACOBIRADAURIGHT"
+ ELSE
+ ans = "GaussJacobiRadauRight"
+ END IF
+
+ CASE (ip%GaussUltraspherical)
+ IF (isUpper0) THEN
+ ans = "GAUSSULTRASPHERICAL"
+ ELSE
+ ans = "GaussUltraspherical"
+ END IF
+
+ CASE (ip%GaussUltrasphericalLobatto)
+ IF (isUpper0) THEN
+ ans = "GAUSSULTRASPHERICALLOBATTO"
+ ELSE
+ ans = "GaussUltrasphericalLobatto"
+ END IF
+
+ CASE (ip%GaussUltrasphericalRadau)
+ IF (isUpper0) THEN
+ ans = "GAUSSULTRASPHERICALRADAU"
+ ELSE
+ ans = "GaussUltrasphericalRadau"
+ END IF
+
+ CASE (ip%GaussUltrasphericalRadauLeft)
+ IF (isUpper0) THEN
+ ans = "GAUSSULTRASPHERICALRADAULEFT"
+ ELSE
+ ans = "GaussUltrasphericalRadauLeft"
+ END IF
+
+ CASE (ip%GaussUltrasphericalRadauRight)
+ IF (isUpper0) THEN
+ ans = "GAUSSULTRASPHERICALRADAURIGHT"
+ ELSE
+ ans = "GaussUltrasphericalRadauRight"
+ END IF
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 InterpolationPoint_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..a46ddded8 100644
--- a/src/modules/BaseType/src/BaseType.F90
+++ b/src/modules/BaseType/src/BaseType.F90
@@ -20,16 +20,78 @@
! [[BaseType]] module contains several userful user defined data types.
MODULE BaseType
-USE GlobalData
+USE GlobalData, ONLY: Monomial, LagrangePolynomial, SerendipityPolynomial, &
+ HierarchicalPolynomial, OrthogonalPolynomial, &
+ JacobiPolynomial, LegendrePolynomial, &
+ ChebyshevPolynomial, LobattoPolynomial, &
+ UnscaledLobattoPolynomial, HermitPolynomial, &
+ UltrasphericalPolynomial
+
+USE GlobalData, ONLY: I4B, LGT, DFP, DFPC
+
+USE GlobalData, ONLY: FMT_NODES, FMT_DOF
+
+USE GlobalData, ONLY: RelativeConvergence, ConvergenceInRes, &
+ ConvergenceInSol, ConvergenceInResSol, &
+ AbsoluteConvergence, NormL2, &
+ StressTypeVoigt, OMP_THREADS_JOINED
+
+USE GlobalData, ONLY: Equidistance, EquidistanceQP, GaussQP, &
+ GaussLegendreQP, GaussLegendreLobattoQP, &
+ GaussLegendreRadau, GaussLegendreRadauLeft, &
+ GaussLegendreRadauRight, GaussRadauQP, &
+ GaussRadauLeftQP, GaussRadauRightQP, &
+ GaussLobattoQP, GaussChebyshevQP, &
+ GaussChebyshevLobattoQP, GaussChebyshevRadau, &
+ GaussChebyshevRadauLeft, GaussChebyshevRadauRight, &
+ GaussJacobiQP, GaussJacobiLobattoQP, &
+ GaussJacobiRadau, GaussJacobiRadauLeft, &
+ GaussJacobiRadauRight, GaussUltraSphericalQP, &
+ GaussUltraSphericalLobattoQP, &
+ GaussUltraSphericalRadau, &
+ GaussUltraSphericalRadauLeft, &
+ GaussUltraSphericalRadauRight, &
+ ChenBabuskaQP, HesthavenQP, &
+ FeketQP, BlythPozLegendreQP, &
+ BlythPozChebyshevQP, IsaacLegendreQP, IsaacChebyshevQP
+
+USE GlobalData, ONLY: NO_PRECONDITION, LEFT_PRECONDITION, &
+ RIGHT_PRECONDITION, LEFT_RIGHT_PRECONDITION, &
+ PRECOND_JACOBI, PRECOND_ILU, PRECOND_SSOR, &
+ PRECOND_HYBRID, PRECOND_IS, PRECOND_SAINV, &
+ PRECOND_SAAMG, PRECOND_ILUC, PRECOND_ADDS, &
+ PRECOND_ILUTP, PRECOND_ILUD, PRECOND_ILUDP, &
+ PRECOND_ILU0, PRECOND_ILUK, PRECOND_ILUT
+
+USE GlobalData, ONLY: LIS_CG, LIS_BCG, LIS_BICG, LIS_CGS, LIS_BCGSTAB, &
+ LIS_BICGSTAB, LIS_BICGSTABL, LIS_GPBICG, LIS_TFQMR, &
+ LIS_OMN, LIS_FOM, LIS_ORTHOMIN, LIS_GMRES, LIS_GMR, &
+ LIS_JACOBI, LIS_GS, LIS_SOR, LIS_BICGSAFE, LIS_CR, &
+ LIS_BICR, LIS_CRS, LIS_BICRSTAB, LIS_GPBICR, &
+ LIS_BICRSAFE, LIS_FGMRES, LIS_IDRS, LIS_IDR1, &
+ LIS_MINRES, LIS_COCG, LIS_COCR, LIS_CGNR, LIS_CGN, &
+ LIS_DBCG, LIS_DBICG, LIS_DQGMRES, LIS_SUPERLU
+
+USE GlobalData, ONLY: Scalar, Vector, Matrix, Nodal, Quadrature, &
+ Constant, Space, Time, Spacetime, &
+ SolutionDependent, RandomSpace
+
+USE GlobalData, ONLY: Point, Line, Triangle, &
+ Quadrangle, Quadrangle4, Quadrangle8, Quadrangle9, &
+ Quadrangle16, &
+ Tetrahedron, Hexahedron, Prism, Pyramid
+
USE String_Class, ONLY: String
+
#ifdef USE_SuperLU
USE SuperLUInterface
USE ISO_C_BINDING, ONLY: C_CHAR, C_PTR, C_SIZE_T
#endif
+
IMPLICIT NONE
PRIVATE
-PUBLIC :: Math
+PUBLIC :: TypeMathOpt
PUBLIC :: BoundingBox_
PUBLIC :: TypeBoundingBox
PUBLIC :: BoundingBoxPointer_
@@ -159,6 +221,7 @@ MODULE BaseType
PUBLIC :: DG_
PUBLIC :: TypeDG
PUBLIC :: DEL_NONE, DEL_X, DEL_Y, DEL_Z, DEL_X_ALL, DEL_t
+PUBLIC :: DerivativeTerm_, TypeDerivativeTerm
PUBLIC :: ElementData_
PUBLIC :: TypeElementData
PUBLIC :: ElementDataPointer_
@@ -189,31 +252,51 @@ 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_
+! MathOpt_
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 March 2022
! summary: Math class
-TYPE :: Math_
- REAL(DFP) :: PI = 3.14159265359_DFP
+TYPE :: MathOpt_
+ REAL(DFP) :: zero = 0.0_DFP
+ REAL(DFP) :: half = 0.5_DFP
+ REAL(DFP) :: one = 1.0_DFP
+ REAL(DFP) :: two = 2.0_DFP
+ REAL(DFP) :: pi = 3.14159265359_DFP
REAL(DFP) :: e = 2.718281828459045_DFP
+ REAL(DFP), DIMENSION(3, 3) :: eye3 = RESHAPE([ &
+ 1.0_DFP, 0.0_DFP, 0.0_DFP, &
+ 0.0_DFP, 1.0_DFP, 0.0_DFP, &
+ 0.0_DFP, 0.0_DFP, 1.0_DFP], &
+ [3, 3])
+ REAL(DFP), DIMENSION(2, 2) :: eye2 = RESHAPE([ &
+ 1.0_DFP, 0.0_DFP, &
+ 0.0_DFP, 1.0_DFP], &
+ [2, 2])
COMPLEX(DFPC) :: i = (0.0_DFP, 1.0_DFP)
COMPLEX(DFPC) :: j = (0.0_DFP, 1.0_DFP)
- REAL(DFP), DIMENSION(3, 3) :: Eye3 = RESHAPE([ &
- & 1.0_DFP, 0.0_DFP, 0.0_DFP, &
- & 0.0_DFP, 1.0_DFP, 0.0_DFP, &
- & 0.0_DFP, 0.0_DFP, 1.0_DFP], &
- & [3, 3])
- REAL(DFP), DIMENSION(2, 2) :: Eye2 = RESHAPE([ &
- & 1.0_DFP, 0.0_DFP, 0.0_DFP, 1.0_DFP], &
- & [2, 2])
-END TYPE Math_
+ LOGICAL(LGT) :: yes = .TRUE.
+ LOGICAL(LGT) :: no = .FALSE.
+ INTEGER(I4B) :: zero_i = 0_I4B
+ INTEGER(I4B) :: one_i = 1_I4B
+ INTEGER(I4B) :: two_i = 2_I4B
+END TYPE MathOpt_
-TYPE(Math_), PARAMETER :: Math = Math_()
+TYPE(MathOpt_), PARAMETER :: TypeMathOpt = MathOpt_()
!----------------------------------------------------------------------------
! BoundingBox_
@@ -268,11 +351,11 @@ MODULE BaseType
TYPE :: RealMatrix_
INTEGER(I4B) :: tDimension = 0_I4B
- CHARACTER(5) :: MatrixProp = 'UNSYM'
- REAL(DFP), ALLOCATABLE :: Val(:, :)
+ CHARACTER(5) :: matrixProp = 'UNSYM'
+ REAL(DFP), ALLOCATABLE :: val(:, :)
END TYPE RealMatrix_
-TYPE(RealMatrix_), PARAMETER :: TypeRealMatrix = RealMatrix_(Val=NULL())
+TYPE(RealMatrix_), PARAMETER :: TypeRealMatrix = RealMatrix_(val=NULL())
TYPE :: RealMatrixPointer_
CLASS(RealMatrix_), POINTER :: ptr => NULL()
@@ -290,10 +373,10 @@ MODULE BaseType
TYPE :: IntVector_
INTEGER(I4B) :: tDimension = 1_I4B
- INTEGER(I4B), ALLOCATABLE :: Val(:)
+ INTEGER(I4B), ALLOCATABLE :: val(:)
END TYPE IntVector_
-TYPE(IntVector_), PARAMETER :: TypeIntVector = IntVector_(Val=NULL())
+TYPE(IntVector_), PARAMETER :: TypeIntVector = IntVector_(val=NULL())
TYPE :: IntVectorPointer_
CLASS(IntVector_), POINTER :: ptr => NULL()
@@ -519,8 +602,8 @@ MODULE BaseType
#endif
END TYPE CSRMatrix_
-TYPE(CSRMatrix_), PARAMETER :: TypeCSRMatrix = CSRMatrix_(&
- & A=NULL(), slu=NULL())
+TYPE(CSRMatrix_), PARAMETER :: TypeCSRMatrix = CSRMatrix_( &
+ A=NULL(), slu=NULL())
TYPE :: CSRMatrixPointer_
CLASS(CSRMatrix_), POINTER :: ptr => NULL()
@@ -1027,25 +1110,39 @@ END SUBROUTINE highorder_refelem
!
! {!pages/FEVariable_.md!}
-INTEGER(I4B), PARAMETER, PUBLIC :: MAX_RANK_FEVARIABLE = 6
-
TYPE :: FEVariable_
- REAL(DFP), ALLOCATABLE :: val(:)
- !! values
+ LOGICAL(LGT) :: isInit = .FALSE.
+ !! True if it is initiated
INTEGER(I4B) :: s(MAX_RANK_FEVARIABLE) = 0
!! shape of the data
+ INTEGER(I4B) :: tshape = 0
+ !! Total shape of the data.
+ !! Following values are set based on rank and varType
+ !! Scalar, constant: 1
+ !! Scalar, space: 1
+ !! Scalar, time: 1
+ !! Scalar, spaceTime: 2
+ !! Vector, constant: 1
+ !! Vector, space: 2
+ !! Vector, time: 3
+ !! Vector, spaceTime: 3
+ !! Matrix, constant: 2
+ !! Matrix, space: 3
+ !! Matrix, time: 3
+ !! Matrix, spaceTime: 4
INTEGER(I4B) :: defineOn = 0
!! Nodal: nodal values
!! Quadrature: quadrature values
INTEGER(I4B) :: varType = 0
- !! Space
- !! Time
- !! SpaceTime
- !! Constant
+ !! Space ! Time ! SpaceTime ! Constant
INTEGER(I4B) :: rank = 0
- !! Scalar
- !! Vector
- !! Matrix
+ !! Scalar ! Vector ! Matrix
+ INTEGER(I4B) :: len = 0_I4B
+ !! current total size
+ INTEGER(I4B) :: capacity = 0_I4B
+ !! capacity of the val
+ REAL(DFP), ALLOCATABLE :: val(:)
+ !! values
END TYPE FEVariable_
TYPE(FEVariable_), PARAMETER :: TypeFEVariable = FEVariable_(val=NULL())
@@ -1082,10 +1179,8 @@ END SUBROUTINE highorder_refelem
!! INTEGER(I4B):: Val = 2
END TYPE FEVariableSpace_
-TYPE(FEVariableSpace_), PARAMETER :: TypeFEVariableSpace = &
- & FEVariableSpace_()
-TYPE(FEVariableSpace_), PARAMETER :: TypeVariableSpace = &
- & FEVariableSpace_()
+TYPE(FEVariableSpace_), PARAMETER :: TypeFEVariableSpace = FEVariableSpace_()
+TYPE(FEVariableSpace_), PARAMETER :: TypeVariableSpace = FEVariableSpace_()
!----------------------------------------------------------------------------
! FEVariableSpaceTime_
@@ -1193,8 +1288,8 @@ END SUBROUTINE highorder_refelem
INTEGER(I4B) :: txi = 0
END TYPE QuadraturePoint_
-TYPE(QuadraturePoint_), PARAMETER :: TypeQuadraturePoint &
- & = QuadraturePoint_(points=NULL())
+TYPE(QuadraturePoint_), PARAMETER :: TypeQuadraturePoint = &
+ QuadraturePoint_(points=NULL())
TYPE :: QuadraturePointPointer_
CLASS(QuadraturePoint_), POINTER :: ptr => NULL()
@@ -1352,6 +1447,21 @@ END SUBROUTINE highorder_refelem
INTEGER(I4B), PARAMETER :: DEL_X_ALL = 4
INTEGER(I4B), PARAMETER :: DEL_t = -1
+!----------------------------------------------------------------------------
+! DerivativeTerm_
+!----------------------------------------------------------------------------
+
+TYPE :: DerivativeTerm_
+ INTEGER(I4B) :: NONE = 0
+ INTEGER(I4B) :: x = 1
+ INTEGER(I4B) :: y = 2
+ INTEGER(I4B) :: z = 3
+ INTEGER(I4B) :: xAll = 4
+ INTEGER(I4B) :: t = -1
+END TYPE DerivativeTerm_
+
+TYPE(DerivativeTerm_), PARAMETER :: TypeDerivativeTerm = DerivativeTerm_()
+
!----------------------------------------------------------------------------
! ElementData_
!----------------------------------------------------------------------------
@@ -1406,7 +1516,7 @@ END SUBROUTINE highorder_refelem
& Jacobian=NULL())
TYPE :: ShapeDataPointer_
- CLASS(ShapeDataPointer_), POINTER :: ptr => NULL()
+ CLASS(ShapeData_), POINTER :: ptr => NULL()
END TYPE ShapeDataPointer_
!----------------------------------------------------------------------------
@@ -1448,44 +1558,54 @@ 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)`
+ !! shape: (nns, nips)
+ !! dim 1 = number of nodes in element
+ !! dim 2 = number of integration points
REAL(DFP), ALLOCATABLE :: dNdXi(:, :, :)
- !! Local derivative of a shape function
+ !! Local derivative of a shape function
+ !! shape = nns, xidim, nips
+ !! dim 1 = number of nodes in element
+ !! dim 2 = xi dimension (xi, eta, zeta)
+ !! dim 3 = number of integration points
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 +1619,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 +1709,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 +1860,203 @@ 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) :: quadrangle8 = Quadrangle8
+ INTEGER(I4B) :: quadrangle9 = Quadrangle9
+ INTEGER(I4B) :: quadrangle16 = Quadrangle16
+ 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
+ INTEGER(I4B) :: default = Monomial
+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
+ INTEGER(I4B) :: default = GaussLegendreQP
+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
+ INTEGER(I4B) :: maxRank = MAX_RANK_FEVARIABLE
+ INTEGER(I4B) :: capacityExpandFactor = 1
+ INTEGER(I4B) :: defaultVectorSize = 3
+ INTEGER(I4B) :: defaultMatrixSize = 3
+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..dd8cabe7e 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.
@@ -57,792 +57,811 @@ module befor64_pack_data_m
!<...
! 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
+ MODULE PROCEDURE &
+ pack_data_R8_R4, pack_data_R8_I8, pack_data_R8_I4, pack_data_R8_I2, &
+ pack_data_R8_I1, pack_data_R4_R8, pack_data_R4_I8, pack_data_R4_I4, &
+ pack_data_R4_I2, pack_data_R4_I1, pack_data_I8_R8, pack_data_I8_R4, &
+ pack_data_I8_I4, pack_data_I8_I2, pack_data_I8_I1, 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, pack_data_I4_I4
+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
+
+PURE SUBROUTINE pack_data_I4_I4(a1, a2, packed)
+ INTEGER(I4P), INTENT(IN) :: a1(1:)
+ INTEGER(I4P), INTENT(IN) :: a2(1:)
+ INTEGER(I1P), ALLOCATABLE, INTENT(INOUT) :: packed(:)
+ !> main
+ INTEGER(I1P), ALLOCATABLE :: p1(:)
+ INTEGER(I1P), ALLOCATABLE :: p2(:)
+ p1 = TRANSFER(a1, p1)
+ p2 = TRANSFER(a2, p2)
+ packed = [p1, p2]
+END SUBROUTINE pack_data_I4_I4
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
endmodule befor64_pack_data_m
diff --git a/src/modules/BoundingBox/src/BoundingBox_Method.F90 b/src/modules/BoundingBox/src/BoundingBox_Method.F90
index 0df44a5c4..80a1eb43e 100644
--- a/src/modules/BoundingBox/src/BoundingBox_Method.F90
+++ b/src/modules/BoundingBox/src/BoundingBox_Method.F90
@@ -30,25 +30,27 @@ MODULE BoundingBox_Method
USE tomlf, ONLY: toml_table
IMPLICIT NONE
-PUBLIC :: OPERATOR(.Xmin.)
+PUBLIC :: OPERATOR(.Center.)
+PUBLIC :: OPERATOR(.Intersection.)
+PUBLIC :: OPERATOR(.Nptrs.)
+PUBLIC :: OPERATOR(.UNION.)
PUBLIC :: OPERATOR(.Xmax.)
-PUBLIC :: OPERATOR(.Ymin.)
+PUBLIC :: OPERATOR(.Xmin.)
PUBLIC :: OPERATOR(.Ymax.)
-PUBLIC :: OPERATOR(.Zmin.)
+PUBLIC :: OPERATOR(.Ymin.)
PUBLIC :: OPERATOR(.Zmax.)
-PUBLIC :: OPERATOR(.isIntersect.)
-PUBLIC :: OPERATOR(.Intersection.)
-PUBLIC :: OPERATOR(.UNION.)
-PUBLIC :: OPERATOR(.Center.)
+PUBLIC :: OPERATOR(.Zmin.)
PUBLIC :: OPERATOR(.isInside.)
-PUBLIC :: OPERATOR(.Nptrs.)
+PUBLIC :: OPERATOR(.isIntersect.)
PUBLIC :: ASSIGNMENT(=)
PUBLIC :: Initiate
+PUBLIC :: Copy
PUBLIC :: BoundingBox
PUBLIC :: BoundingBox_Pointer
PUBLIC :: DEALLOCATE
+PUBLIC :: Reallocate
PUBLIC :: Display
PUBLIC :: isIntersectInX
@@ -146,6 +148,10 @@ END SUBROUTINE Initiate_2
MODULE PROCEDURE Initiate_2
END INTERFACE
+INTERFACE Copy
+ MODULE PROCEDURE Initiate_2
+END INTERFACE Copy
+
!----------------------------------------------------------------------------
! Initiate@ConstructorMethods
!----------------------------------------------------------------------------
@@ -165,6 +171,10 @@ END SUBROUTINE Initiate_3
MODULE PROCEDURE Initiate_3
END INTERFACE
+INTERFACE Copy
+ MODULE PROCEDURE Initiate_3
+END INTERFACE Copy
+
!----------------------------------------------------------------------------
! Append@ConstructorMethods
!----------------------------------------------------------------------------
@@ -358,7 +368,7 @@ END SUBROUTINE BB_Deallocate
END INTERFACE DEALLOCATE
!----------------------------------------------------------------------------
-! Deallocate@Constructor
+! Deallocate@Constructor
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -371,6 +381,21 @@ MODULE PURE SUBROUTINE BB_Deallocate2(obj)
END SUBROUTINE BB_Deallocate2
END INTERFACE DEALLOCATE
+!----------------------------------------------------------------------------
+! Reallocate@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-07-25
+! summary: Reallocate the bounding box if necessary
+
+INTERFACE Reallocate
+ MODULE PURE SUBROUTINE obj_Reallocate(obj, tsize)
+ TYPE(BoundingBox_), ALLOCATABLE, INTENT(INOUT) :: obj(:)
+ INTEGER(I4B), INTENT(IN) :: tsize
+ END SUBROUTINE obj_Reallocate
+END INTERFACE Reallocate
+
!----------------------------------------------------------------------------
! Display@Constructor
!----------------------------------------------------------------------------
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..073cd78ae 100644
--- a/src/modules/CMakeLists.txt
+++ b/src/modules/CMakeLists.txt
@@ -60,8 +60,7 @@ include(${CMAKE_CURRENT_LIST_DIR}/ARPACK/CMakeLists.txt)
# Hashing
include(${CMAKE_CURRENT_LIST_DIR}/Hashing/CMakeLists.txt)
-# Gnuplot
-include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt)
+# Gnuplot include(${CMAKE_CURRENT_LIST_DIR}/Gnuplot/CMakeLists.txt)
# CInterface
include(${CMAKE_CURRENT_LIST_DIR}/CInterface/CMakeLists.txt)
@@ -96,6 +95,30 @@ include(${CMAKE_CURRENT_LIST_DIR}/BaseInterpolation/CMakeLists.txt)
# BaseContinuity
include(${CMAKE_CURRENT_LIST_DIR}/BaseContinuity/CMakeLists.txt)
+# Point
+include(${CMAKE_CURRENT_LIST_DIR}/Point/CMakeLists.txt)
+
+# Line
+include(${CMAKE_CURRENT_LIST_DIR}/Line/CMakeLists.txt)
+
+# Triangle
+include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt)
+
+# Quadrangle
+include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt)
+
+# Tetrahedron
+include(${CMAKE_CURRENT_LIST_DIR}/Tetrahedron/CMakeLists.txt)
+
+# Hexahedron
+include(${CMAKE_CURRENT_LIST_DIR}/Hexahedron/CMakeLists.txt)
+
+# Prism
+include(${CMAKE_CURRENT_LIST_DIR}/Prism/CMakeLists.txt)
+
+# Pyramid
+include(${CMAKE_CURRENT_LIST_DIR}/Pyramid/CMakeLists.txt)
+
# Polynomial
include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt)
@@ -192,6 +215,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt)
# FEVector
include(${CMAKE_CURRENT_LIST_DIR}/FEVector/CMakeLists.txt)
+# Projection
+include(${CMAKE_CURRENT_LIST_DIR}/Projection/CMakeLists.txt)
+
# VoigtRank2Tensor
include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt)
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90
index 90411faa2..8a98e7b39 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_AddMethods.F90
@@ -20,7 +20,48 @@ MODULE CSRMatrix_AddMethods
IMPLICIT NONE
PRIVATE
-PUBLIC :: Add
+PUBLIC :: Add, Add_
+PUBLIC :: AddToSTMatrix
+
+!----------------------------------------------------------------------------
+! Add@addMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 Marach 2021
+! summary: This subroutine Add contribution
+
+INTERFACE AddMaster
+ MODULE PURE SUBROUTINE AddMaster1(obj, row, col, VALUE, scale)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: row(:), col(:)
+ !! Node numbers
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ !! Element finite element matrix
+ REAL(DFP), INTENT(IN) :: scale
+ !! Scale is used to scale the Val before Adding it to the obj
+ END SUBROUTINE AddMaster1
+END INTERFACE AddMaster
+
+!----------------------------------------------------------------------------
+! Add@addMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 Marach 2021
+! summary: This subroutine Add contribution
+
+INTERFACE AddMaster
+ MODULE PURE SUBROUTINE AddMaster2(obj, row, col, VALUE, scale)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: row(:), col(:)
+ !! Node numbers
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! Element finite element matrix
+ REAL(DFP), INTENT(IN) :: scale
+ !! Scale is used to scale the Val before Adding it to the obj
+ END SUBROUTINE AddMaster2
+END INTERFACE AddMaster
!----------------------------------------------------------------------------
! Add@addMethod
@@ -50,6 +91,33 @@ END SUBROUTINE obj_Add0
! date: 22 Marach 2021
! summary: This subroutine Add contribution
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_0(obj, nodenum, VALUE, scale, row, col, &
+ nrow, ncol)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! Node numbers
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ !! Element finite element matrix
+ REAL(DFP), INTENT(IN) :: scale
+ !! Scale is used to scale the Val before Adding it to the obj
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ !! needed for internal working
+ !! size of row should be .tdof. obj%csr%idof * size(nodenum)
+ !! size of col should be .tdof. obj%csr%jdof * size(nodenum)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! data written in row and col
+ END SUBROUTINE obj_Add_0
+END INTERFACE Add_
+
+!----------------------------------------------------------------------------
+! Add@addMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 Marach 2021
+! summary: This subroutine Add contribution
+
INTERFACE Add
MODULE PURE SUBROUTINE obj_Add1(obj, nodenum, VALUE, scale, storageFMT)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
@@ -68,6 +136,38 @@ END SUBROUTINE obj_Add1
! Add@addMethod
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 22 Marach 2021
+! summary: This subroutine Add contribution
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_1( &
+ obj, nodenum, VALUE, scale, storageFMT, m2, m2_nrow, m2_ncol, row, &
+ col, nrow, ncol)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! Node numbers
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ !! Element finite element matrix
+ REAL(DFP), INTENT(IN) :: scale
+ !! Scale is used to scale the Val before Adding it to the obj
+ INTEGER(I4B), INTENT(IN) :: storageFMT
+ !! Storage format of element finite matrix
+ REAL(DFP), INTENT(INOUT) :: m2(:, :)
+ !! need for internal working
+ !! Size should at least enough to hold value
+ INTEGER(I4B), INTENT(OUT) :: m2_nrow, m2_ncol
+ !! size of m2
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ !! needed for internal working
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_1
+END INTERFACE Add_
+
+!----------------------------------------------------------------------------
+! Add@addMethod
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 22 March 2021
! summary: Adds all values of sparse matrix to given scalar value
@@ -84,6 +184,10 @@ MODULE PURE SUBROUTINE obj_Add2(obj, VALUE, scale)
END SUBROUTINE obj_Add2
END INTERFACE Add
+INTERFACE Add_
+ MODULE PROCEDURE obj_Add2
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -110,6 +214,10 @@ MODULE PURE SUBROUTINE obj_Add3(obj, irow, icolumn, VALUE, scale)
END SUBROUTINE obj_Add3
END INTERFACE Add
+INTERFACE Add_
+ MODULE PROCEDURE obj_Add3
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -128,7 +236,7 @@ END SUBROUTINE obj_Add3
INTERFACE Add
MODULE PURE SUBROUTINE obj_Add4(obj, iNodeNum, jNodeNum, idof, &
- & jdof, VALUE, scale)
+ jdof, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
INTEGER(I4B), INTENT(IN) :: jNodeNum
@@ -139,6 +247,10 @@ MODULE PURE SUBROUTINE obj_Add4(obj, iNodeNum, jNodeNum, idof, &
END SUBROUTINE obj_Add4
END INTERFACE Add
+INTERFACE Add_
+ MODULE PROCEDURE obj_Add4
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -160,6 +272,26 @@ END SUBROUTINE obj_Add5
! Add@addMethod
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: This subroutine Add the selected value in sparse matrix
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_5(obj, nodenum, VALUE, scale, &
+ row, col, nrow, ncol)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ REAL(DFP), INTENT(IN) :: VALUE
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_5
+END INTERFACE Add_
+
+!----------------------------------------------------------------------------
+! Add@addMethod
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 22 March 2021
! summary: This subroutine Add the value in sparse matrix
@@ -173,11 +305,10 @@ END SUBROUTINE obj_Add5
!$$
! obj(Nptrs,Nptrs)=value(:,:)
!$$
-!
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(:)
@@ -188,13 +319,32 @@ MODULE PURE SUBROUTINE obj_Add6(obj, iNodeNum, jNodeNum, &
END SUBROUTINE obj_Add6
END INTERFACE Add
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_6( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, VALUE, scale, row, col, nrow, ncol)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
+ INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
+ INTEGER(I4B), INTENT(IN) :: ivar
+ INTEGER(I4B), INTENT(IN) :: jvar
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_6
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 22 March 2021
-! summary: Adds the specific row and column entry to a given value
+! date: 22 March 2021
+! summary: Adds the specific row and column entry to a given value
!
!# Introduction
!
@@ -217,8 +367,8 @@ END SUBROUTINE obj_Add6
!@endnote
INTERFACE Add
- MODULE PURE SUBROUTINE obj_Add7(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, iDOF, jDOF, VALUE, scale)
+ MODULE PURE SUBROUTINE obj_Add7(obj, iNodeNum, jNodeNum, ivar, &
+ jvar, iDOF, jDOF, VALUE, scale)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
!! row node number
@@ -238,6 +388,10 @@ MODULE PURE SUBROUTINE obj_Add7(obj, iNodeNum, jNodeNum, ivar, &
END SUBROUTINE obj_Add7
END INTERFACE Add
+INTERFACE Add_
+ MODULE PROCEDURE obj_Add7
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -247,8 +401,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
@@ -268,6 +422,36 @@ MODULE PURE SUBROUTINE obj_Add8(obj, iNodeNum, jNodeNum, ivar, &
END SUBROUTINE obj_Add8
END INTERFACE Add
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_8( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, iDOF, jDOF, VALUE, scale, &
+ row, col, nrow, ncol)
+ 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
+ !!
+ INTEGER(I4B), INTENT(IN) :: jvar
+ !!
+ INTEGER(I4B), INTENT(IN) :: iDOF
+ !! row degree of freedom
+ INTEGER(I4B), INTENT(IN) :: jDOF
+ !! col degree of freedom
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ !! scalar value to be Add
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_8
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -297,8 +481,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
@@ -318,6 +502,10 @@ MODULE PURE SUBROUTINE obj_Add9(obj, iNodeNum, jNodeNum, ivar, &
END SUBROUTINE obj_Add9
END INTERFACE Add
+INTERFACE Add_
+ MODULE PROCEDURE obj_Add9
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -339,7 +527,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(:)
@@ -350,6 +538,26 @@ MODULE PURE SUBROUTINE obj_Add10(obj, iNodeNum, jNodeNum, &
END SUBROUTINE obj_Add10
END INTERFACE Add
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_10( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, VALUE, scale, row, col, nrow, &
+ ncol)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
+ INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
+ INTEGER(I4B), INTENT(IN) :: ivar
+ INTEGER(I4B), INTENT(IN) :: jvar
+ REAL(DFP), INTENT(IN) :: VALUE
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_10
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -359,8 +567,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
@@ -380,6 +588,35 @@ MODULE PURE SUBROUTINE obj_Add11(obj, iNodeNum, jNodeNum, ivar, &
END SUBROUTINE obj_Add11
END INTERFACE Add
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_11( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, iDOF, jDOF, VALUE, scale, &
+ row, col, nrow, ncol)
+ 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
+ !!
+ INTEGER(I4B), INTENT(IN) :: jvar
+ !!
+ INTEGER(I4B), INTENT(IN) :: iDOF
+ !! row degree of freedom
+ INTEGER(I4B), INTENT(IN) :: jDOF
+ !! col degree of freedom
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! scalar value to be Add
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_11
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -389,8 +626,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
@@ -418,9 +655,10 @@ END SUBROUTINE obj_Add12
! date: 17/01/2022
! 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)
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_12( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, &
+ jspacecompo, jtimecompo, VALUE, scale, row, col, nrow, ncol)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
!! row node number
@@ -431,6 +669,38 @@ MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, &
INTEGER(I4B), INTENT(IN) :: jvar
!!
INTEGER(I4B), INTENT(IN) :: ispacecompo
+ INTEGER(I4B), INTENT(IN) :: itimecompo
+ INTEGER(I4B), INTENT(IN) :: jspacecompo
+ INTEGER(I4B), INTENT(IN) :: jtimecompo
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! scalar value to be Add
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_12
+END INTERFACE Add_
+
+!----------------------------------------------------------------------------
+! Add@addMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 17/01/2022
+! 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)
+ 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
INTEGER(I4B), INTENT(IN) :: jtimecompo(:)
@@ -440,6 +710,35 @@ MODULE PURE SUBROUTINE obj_Add13(obj, iNodeNum, jNodeNum, ivar, &
END SUBROUTINE obj_Add13
END INTERFACE Add
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_13( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, &
+ jspacecompo, jtimecompo, VALUE, scale, row, col, nrow, ncol)
+ 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
+ INTEGER(I4B), INTENT(IN) :: jtimecompo(:)
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! scalar value to be Add
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_13
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@addMethod
!----------------------------------------------------------------------------
@@ -470,6 +769,35 @@ MODULE PURE SUBROUTINE obj_Add14(obj, iNodeNum, jNodeNum, ivar, &
END SUBROUTINE obj_Add14
END INTERFACE Add
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+INTERFACE Add_
+ MODULE PURE SUBROUTINE obj_Add_14( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, ispacecompo, itimecompo, &
+ jspacecompo, jtimecompo, VALUE, scale, row, col, nrow, ncol)
+ 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
+ !!
+ INTEGER(I4B), INTENT(IN) :: jvar
+ !!
+ INTEGER(I4B), INTENT(IN) :: ispacecompo(:)
+ INTEGER(I4B), INTENT(IN) :: itimecompo
+ INTEGER(I4B), INTENT(IN) :: jspacecompo(:)
+ INTEGER(I4B), INTENT(IN) :: jtimecompo
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! scalar value to be Add
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(INOUT) :: row(:), col(:)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Add_14
+END INTERFACE Add_
+
!----------------------------------------------------------------------------
! Add@Methods
!----------------------------------------------------------------------------
@@ -483,8 +811,8 @@ END SUBROUTINE obj_Add14
! Add a csrmatrix to another csrmatrix
INTERFACE Add
- MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, &
- & isSorted)
+ MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, &
+ isSorted)
TYPE(CSRMatrix_), INTENT(INOUT) :: obj
!! CSRMatrix_
TYPE(CSRMatrix_), INTENT(IN) :: VALUE
@@ -498,6 +826,44 @@ MODULE SUBROUTINE obj_Add15(obj, VALUE, scale, isSameStructure, &
END SUBROUTINE obj_Add15
END INTERFACE Add
+INTERFACE Add_
+ MODULE PROCEDURE obj_Add15
+END INTERFACE Add_
+
+!----------------------------------------------------------------------------
+! Add@AddMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-12-17
+! summary: (Obj)ab = Value
+!
+!# Introduction
+!
+! In time discontinuous fem, tangent matrix is block matrix
+! First we assemble mass and stiffness matrix separately
+! they can be represented by Value.
+! Now we want to make one of the blocks of space-time matrix
+! which is represented by Obj.
+! This routine performs this task.
+! Note that the storage format of Obj should be FMT_DOF
+! Note that the storage format of Value and one of the blocks should be
+! identical.
+
+INTERFACE AddToSTMatrix
+ MODULE PURE SUBROUTINE obj_AddToSTMatrix1( &
+ obj, VALUE, itimecompo, jtimecompo, scale)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ !! space-time matrix, format should be FMT_DOF
+ TYPE(CSRMatrix_), INTENT(IN) :: VALUE
+ !! space matrix
+ INTEGER(I4B), INTENT(IN) :: itimecompo, jtimecompo
+ !! time components
+ REAL(DFP), OPTIONAL, INTENT(IN) :: scale
+ !! scale
+ END SUBROUTINE obj_AddToSTMatrix1
+END INTERFACE AddToSTMatrix
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
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..62b1e2523 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_GetMethods.F90
@@ -39,102 +39,126 @@ MODULE CSRMatrix_GetMethods
PUBLIC :: GetValue
!----------------------------------------------------------------------------
-! GetIA@GetMethods
+! GetIA
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get entry in IA
-INTERFACE GetIA
+INTERFACE
MODULE PURE FUNCTION obj_GetIA(obj, irow) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: irow
INTEGER(I4B) :: ans
END FUNCTION obj_GetIA
+END INTERFACE
+
+INTERFACE GetIA
+ MODULE PROCEDURE obj_GetIA
END INTERFACE GetIA
!----------------------------------------------------------------------------
-! GetJA@GetMethods
+! GetJA
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get entry in JA
-INTERFACE GetJA
+INTERFACE
MODULE PURE FUNCTION obj_GetJA(obj, indx) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
INTEGER(I4B) :: ans
END FUNCTION obj_GetJA
+END INTERFACE
+
+INTERFACE GetJA
+ MODULE PROCEDURE obj_GetJA
END INTERFACE GetJA
!----------------------------------------------------------------------------
-! GetSingleValue
+! GetSingleValue
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get single value
-INTERFACE GetSingleValue
+INTERFACE
MODULE PURE FUNCTION obj_GetSingleValue(obj, indx) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
REAL(DFP) :: ans
END FUNCTION obj_GetSingleValue
-END INTERFACE GetSingleValue
+END INTERFACE
INTERFACE Get
MODULE PROCEDURE obj_GetSingleValue
END INTERFACE Get
+INTERFACE GetSingleValue
+ MODULE PROCEDURE obj_GetSingleValue
+END INTERFACE GetSingleValue
+
!----------------------------------------------------------------------------
-! GetSingleValue
+! GetSingleValue
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get single value
-INTERFACE GetSeveralValue
+INTERFACE
MODULE PURE FUNCTION obj_GetSeveralValue(obj, indx) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx(:)
REAL(DFP) :: ans(SIZE(indx))
END FUNCTION obj_GetSeveralValue
-END INTERFACE GetSeveralValue
+END INTERFACE
INTERFACE Get
MODULE PROCEDURE obj_GetSeveralValue
END INTERFACE Get
+INTERFACE GetSeveralValue
+ MODULE PROCEDURE obj_GetSeveralValue
+END INTERFACE GetSeveralValue
+
!----------------------------------------------------------------------------
-! GetStorageFMT@getMethods
+! GetStorageFMT
!----------------------------------------------------------------------------
-INTERFACE GetStorageFMT
+INTERFACE
MODULE PURE FUNCTION obj_GetStorageFMT(obj, i) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: i
INTEGER(I4B) :: ans
END FUNCTION obj_GetStorageFMT
+END INTERFACE
+
+INTERFACE GetStorageFMT
+ MODULE PROCEDURE obj_GetStorageFMT
END INTERFACE GetStorageFMT
-INTERFACE OPERATOR(.storageFMT.)
+INTERFACE OPERATOR(.StorageFMT.)
MODULE PROCEDURE obj_GetStorageFMT
-END INTERFACE OPERATOR(.storageFMT.)
+END INTERFACE OPERATOR(.StorageFMT.)
!----------------------------------------------------------------------------
-! GetMatrixProp@getMethod
+! GetMatrixProp
!----------------------------------------------------------------------------
-INTERFACE GetMatrixProp
+INTERFACE
MODULE PURE FUNCTION obj_GetMatrixProp(obj) RESULT(ans)
TYPE(CSRMatrix_), TARGET, INTENT(IN) :: obj
CHARACTER(20) :: ans
END FUNCTION obj_GetMatrixProp
+END INTERFACE
+
+INTERFACE GetMatrixProp
+ MODULE PROCEDURE obj_GetMatrixProp
END INTERFACE GetMatrixProp
INTERFACE OPERATOR(.MatrixProp.)
@@ -142,105 +166,133 @@ END FUNCTION obj_GetMatrixProp
END INTERFACE OPERATOR(.MatrixProp.)
!----------------------------------------------------------------------------
-! GetDOFPointer@getMethod
+! GetDOFPointer
!----------------------------------------------------------------------------
-INTERFACE GetDOFPointer
+INTERFACE
MODULE FUNCTION obj_GetDOFPointer(obj, i) RESULT(ans)
TYPE(CSRMatrix_), TARGET, INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: i
CLASS(DOF_), POINTER :: ans
END FUNCTION obj_GetDOFPointer
+END INTERFACE
+
+INTERFACE GetDOFPointer
+ MODULE PROCEDURE obj_GetDOFPointer
END INTERFACE GetDOFPointer
!----------------------------------------------------------------------------
-! isSquare@GetMethod
+! isSquare
!----------------------------------------------------------------------------
-INTERFACE isSquare
- MODULE PURE FUNCTION obj_isSquare(obj) RESULT(ans)
+INTERFACE
+ MODULE PURE FUNCTION obj_IsSquare(obj) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
LOGICAL(LGT) :: ans
- END FUNCTION obj_isSquare
-END INTERFACE isSquare
+ END FUNCTION obj_IsSquare
+END INTERFACE
+
+INTERFACE IsSquare
+ MODULE PROCEDURE obj_IsSquare
+END INTERFACE IsSquare
!----------------------------------------------------------------------------
-! isRectangle@GetMethod
+! isRectangle
!----------------------------------------------------------------------------
-INTERFACE isRectangle
- MODULE PURE FUNCTION obj_isRectangle(obj) RESULT(ans)
+INTERFACE
+ MODULE PURE FUNCTION obj_IsRectangle(obj) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
LOGICAL(LGT) :: ans
- END FUNCTION obj_isRectangle
+ END FUNCTION obj_IsRectangle
+END INTERFACE
+
+INTERFACE isRectangle
+ MODULE PROCEDURE obj_IsRectangle
END INTERFACE isRectangle
!----------------------------------------------------------------------------
-! GetColNumber@GetMethods
+! GetColNumber
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get the column number from JA.
-INTERFACE GetColNumber
+INTERFACE
MODULE PURE FUNCTION obj_GetColNumber(obj, indx) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: indx
INTEGER(I4B) :: ans
END FUNCTION obj_GetColNumber
+END INTERFACE
+
+INTERFACE GetColNumber
+ MODULE PROCEDURE obj_GetColNumber
END INTERFACE GetColNumber
!----------------------------------------------------------------------------
-! GetColIndex@GetMethods
+! GetColIndex
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get the starting and ending column index of irow
-INTERFACE GetColIndex
+INTERFACE
MODULE PURE FUNCTION obj_GetColIndex(obj, irow) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: irow
INTEGER(I4B) :: ans(2)
END FUNCTION obj_GetColIndex
+END INTERFACE
+
+INTERFACE GetColIndex
+ MODULE PROCEDURE obj_GetColIndex
END INTERFACE GetColIndex
!----------------------------------------------------------------------------
-! startColumn@GetMethods
+! startColumn
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get the starting column index of irow
-INTERFACE OPERATOR(.startColumn.)
- MODULE PURE FUNCTION obj_startColumn(obj, irow) RESULT(ans)
+INTERFACE
+ MODULE PURE FUNCTION obj_StartColumn(obj, irow) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: irow
INTEGER(I4B) :: ans
- END FUNCTION obj_startColumn
-END INTERFACE OPERATOR(.startColumn.)
+ END FUNCTION obj_StartColumn
+END INTERFACE
+
+INTERFACE OPERATOR(.StartColumn.)
+ MODULE PROCEDURE obj_StartColumn
+END INTERFACE OPERATOR(.StartColumn.)
!----------------------------------------------------------------------------
-! endColumn@GetMethods
+! endColumn
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-14
! summary: Get the ending column index of irow
-INTERFACE OPERATOR(.endColumn.)
- MODULE PURE FUNCTION obj_endColumn(obj, irow) RESULT(ans)
+INTERFACE
+ MODULE PURE FUNCTION obj_EndColumn(obj, irow) RESULT(ans)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: irow
INTEGER(I4B) :: ans
- END FUNCTION obj_endColumn
-END INTERFACE OPERATOR(.endColumn.)
+ END FUNCTION obj_EndColumn
+END INTERFACE
+
+INTERFACE OPERATOR(.EndColumn.)
+ MODULE PROCEDURE obj_EndColumn
+END INTERFACE OPERATOR(.EndColumn.)
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -254,16 +306,21 @@ END FUNCTION obj_endColumn
! - Usually `value` denotes the element matrix
! - Symbolic we are performing following task `obj(nodenum, nodenum)=value`
-INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get0(obj, nodenum, VALUE)
+INTERFACE
+ 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
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get0
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -287,18 +344,23 @@ END SUBROUTINE obj_Get0
!
! - Usually, element matrix is stored with `DOF_FMT`
-INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get1(obj, nodenum, storageFMT, VALUE)
+INTERFACE
+ 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
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get1
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -317,7 +379,7 @@ END SUBROUTINE obj_Get1
! This routine should be avoided by general user.
!@endwarning
-INTERFACE GetValue
+INTERFACE
MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: irow
@@ -327,22 +389,14 @@ MODULE PURE SUBROUTINE obj_Get2(obj, irow, icolumn, VALUE)
REAL(DFP), INTENT(INOUT) :: VALUE
!! value
END SUBROUTINE obj_Get2
-END INTERFACE GetValue
+END INTERFACE
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE)
- TYPE(CSRMatrix_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN) :: irow(:)
- !! row index
- INTEGER(I4B), INTENT(IN) :: icolumn(:)
- !! column index
- REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
- !! value
- END SUBROUTINE obj_Get10
+ MODULE PROCEDURE obj_Get2
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -370,9 +424,9 @@ END SUBROUTINE obj_Get10
! or later physical variables will not start from 1.
!@endnote
-INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, iDOF, &
- & jDOF, VALUE)
+INTERFACE
+ MODULE PURE SUBROUTINE obj_Get3( &
+ obj, iNodeNum, jNodeNum, iDOF, jDOF, VALUE)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: iNodeNum
!! row node number
@@ -385,10 +439,14 @@ MODULE PURE SUBROUTINE obj_Get3(obj, iNodeNum, jNodeNum, iDOF, &
REAL(DFP), INTENT(INOUT) :: VALUE
!! scalar value to be Get
END SUBROUTINE obj_Get3
+END INTERFACE
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get3
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -405,9 +463,9 @@ END SUBROUTINE obj_Get3
! obj(Nptrs,Nptrs)=value(:,:)
!$$
-INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get4(obj, iNodeNum, jNodeNum, &
- & ivar, jvar, VALUE)
+INTERFACE
+ MODULE PURE SUBROUTINE obj_Get4( &
+ obj, iNodeNum, jNodeNum, ivar, jvar, VALUE, nrow, ncol)
TYPE(CSRMatrix_), INTENT(IN) :: obj
!! Block csr matrix
INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
@@ -420,11 +478,16 @@ 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
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get4
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -451,18 +514,18 @@ END SUBROUTINE obj_Get4
! or later physical variables will not start from 1.
!@endnote
-INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, iDOF, jDOF, VALUE)
+INTERFACE
+ 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
INTEGER(I4B), INTENT(IN) :: jNodeNum
!! column node number
INTEGER(I4B), INTENT(IN) :: ivar
- !!
+ !! physical variable for row
INTEGER(I4B), INTENT(IN) :: jvar
- !!
+ !! physical variable for column
INTEGER(I4B), INTENT(IN) :: iDOF
!! row degree of freedom
INTEGER(I4B), INTENT(IN) :: jDOF
@@ -470,19 +533,23 @@ MODULE PURE SUBROUTINE obj_Get5(obj, iNodeNum, jNodeNum, ivar, &
REAL(DFP), INTENT(INOUT) :: VALUE
!! scalar value to be Get
END SUBROUTINE obj_Get5
+END INTERFACE
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get5
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-12-23
! 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)
+INTERFACE
+ 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 +566,16 @@ 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
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get6
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@getMethods
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -530,9 +602,10 @@ END SUBROUTINE obj_Get6
! or later physical variables will not start from 1.
!@endnote
-INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE)
+INTERFACE
+ 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
@@ -553,39 +626,14 @@ MODULE PURE SUBROUTINE obj_Get7(obj, iNodeNum, jNodeNum, ivar, &
REAL(DFP), INTENT(INOUT) :: VALUE
!! scalar value to be Get
END SUBROUTINE obj_Get7
-END INTERFACE GetValue
-
-!----------------------------------------------------------------------------
-! GetValue
-!----------------------------------------------------------------------------
+END INTERFACE
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_Get9(obj, iNodeNum, jNodeNum, ivar, &
- & jvar, ispacecompo, itimecompo, jspacecompo, jtimecompo, VALUE)
- TYPE(CSRMatrix_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN) :: iNodeNum(:)
- !! row node number
- INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
- !! column node number
- INTEGER(I4B), INTENT(IN) :: ivar
- !! row physical variable
- INTEGER(I4B), INTENT(IN) :: jvar
- !! col physical variable
- INTEGER(I4B), INTENT(IN) :: ispacecompo
- !! row space component
- INTEGER(I4B), INTENT(IN) :: itimecompo
- !! row time component
- INTEGER(I4B), INTENT(IN) :: jspacecompo
- !! col space component
- INTEGER(I4B), INTENT(IN) :: jtimecompo
- !! col time component
- REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
- !! scalar value to be Get
- END SUBROUTINE obj_Get9
+ MODULE PROCEDURE obj_Get7
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@GetMethod
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -596,14 +644,11 @@ 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)
+INTERFACE
+ 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
@@ -635,10 +680,70 @@ MODULE SUBROUTINE obj_Get8(obj1, obj2, &
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: ierr
!! Error code, if 0 no error, else error
END SUBROUTINE obj_Get8
+END INTERFACE
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get8
END INTERFACE GetValue
!----------------------------------------------------------------------------
-! Get@GetMethod
+! GetValue
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+ INTEGER(I4B), INTENT(IN) :: jNodeNum(:)
+ !! column node number
+ INTEGER(I4B), INTENT(IN) :: ivar
+ !! row physical variable
+ INTEGER(I4B), INTENT(IN) :: jvar
+ !! col physical variable
+ INTEGER(I4B), INTENT(IN) :: ispacecompo
+ !! row space component
+ INTEGER(I4B), INTENT(IN) :: itimecompo
+ !! row time component
+ INTEGER(I4B), INTENT(IN) :: jspacecompo
+ !! col space component
+ INTEGER(I4B), INTENT(IN) :: jtimecompo
+ !! 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
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get9
+END INTERFACE GetValue
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_Get10(obj, irow, icolumn, VALUE, nrow, ncol)
+ TYPE(CSRMatrix_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: irow(:)
+ !! row index
+ INTEGER(I4B), INTENT(IN) :: icolumn(:)
+ !! column index
+ REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
+ !! value
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Get10
+END INTERFACE
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get10
+END INTERFACE GetValue
+
+!----------------------------------------------------------------------------
+! Get
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -650,8 +755,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
@@ -669,4 +774,49 @@ MODULE SUBROUTINE CSR2CSR_Get_Master(obj1, obj2, idof1, jdof1, idof2, &
END SUBROUTINE CSR2CSR_Get_Master
END INTERFACE
+!----------------------------------------------------------------------------
+! GetSingleValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-12-14
+! summary: Get single value
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_Get11(obj, indx, ans)
+ TYPE(CSRMatrix_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: indx
+ REAL(DFP), INTENT(INOUT) :: ans
+ END SUBROUTINE obj_Get11
+END INTERFACE
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get11
+END INTERFACE GetValue
+
+!----------------------------------------------------------------------------
+! GetSingleValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-12-14
+! summary: Get single value
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_Get12(obj, indx, ans, tsize)
+ TYPE(CSRMatrix_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: indx(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE obj_Get12
+END INTERFACE
+
+INTERFACE GetValue
+ MODULE PROCEDURE obj_Get12
+END INTERFACE GetValue
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE CSRMatrix_GetMethods
diff --git a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90
index 3ab0128e2..aa7dd02ef 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods.F90
@@ -22,6 +22,8 @@ MODULE CSRMatrix_GetSubMatrixMethods
PRIVATE
PUBLIC :: GetSubMatrix
+PUBLIC :: GetSubMatrix_
+PUBLIC :: GetSubMatrixNNZ
!----------------------------------------------------------------------------
! GetColumn@Methods
@@ -31,13 +33,67 @@ MODULE CSRMatrix_GetSubMatrixMethods
! date: 24 July 2021
! summary: This routine returns the submatrix
-INTERFACE GetSubMatrix
+INTERFACE
+ MODULE SUBROUTINE obj_GetSubMatrixNNZ(obj, cols, selectCol, ans)
+ TYPE(CSRMatrix_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: cols(:)
+ !! column indices to be extracted
+ LOGICAL(LGT), INTENT(INOUT) :: selectCol(:)
+ !! size of subIndices
+ INTEGER(I4B), INTENT(OUT) :: ans
+ END SUBROUTINE obj_GetSubMatrixNNZ
+END INTERFACE
+
+INTERFACE GetSubMatrixNNZ
+ MODULE PROCEDURE obj_GetSubMatrixNNZ
+END INTERFACE GetSubMatrixNNZ
+
+!----------------------------------------------------------------------------
+! GetColumn@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 24 July 2021
+! summary: This routine returns the submatrix
+
+INTERFACE
+ MODULE SUBROUTINE obj_GetSubMatrix_1( &
+ obj, cols, submat, subIndices, selectCol, tsize)
+ TYPE(CSRMatrix_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: cols(:)
+ !! column indices to be extracted
+ TYPE(CSRMatrix_), INTENT(INOUT) :: submat
+ !! CSRMatrix to store the submatrix
+ INTEGER(I4B), INTENT(INOUT) :: subIndices(:)
+ LOGICAL(LGT), INTENT(INOUT) :: selectCol(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! size of subIndices
+ END SUBROUTINE obj_GetSubMatrix_1
+END INTERFACE
+
+INTERFACE GetSubMatrix_
+ MODULE PROCEDURE obj_GetSubMatrix_1
+END INTERFACE GetSubMatrix_
+
+!----------------------------------------------------------------------------
+! GetColumn@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 24 July 2021
+! summary: This routine returns the submatrix
+
+INTERFACE
MODULE SUBROUTINE obj_GetSubMatrix1(obj, cols, submat, subIndices)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: cols(:)
TYPE(CSRMatrix_), INTENT(INOUT) :: submat
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: subIndices(:)
END SUBROUTINE obj_GetSubMatrix1
+END INTERFACE
+
+INTERFACE GetSubMatrix
+ MODULE PROCEDURE obj_GetSubMatrix1
END INTERFACE GetSubMatrix
!----------------------------------------------------------------------------
@@ -48,14 +104,22 @@ END SUBROUTINE obj_GetSubMatrix1
! date: 24 July 2021
! summary: This routine returns the submatrix
-INTERFACE GetSubMatrix
+INTERFACE
MODULE SUBROUTINE obj_GetSubMatrix2(obj, subIndices, submat)
TYPE(CSRMatrix_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: subIndices(:)
TYPE(CSRMatrix_), INTENT(INOUT) :: submat
END SUBROUTINE obj_GetSubMatrix2
+END INTERFACE
+
+INTERFACE GetSubMatrix
+ MODULE PROCEDURE obj_GetSubMatrix2
END INTERFACE GetSubMatrix
+INTERFACE GetSubMatrix_
+ MODULE PROCEDURE obj_GetSubMatrix2
+END INTERFACE GetSubMatrix_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
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/CSRMatrix/src/CSRMatrix_SetMethods.F90 b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90
index 127461fde..293a6b8be 100644
--- a/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90
+++ b/src/modules/CSRMatrix/src/CSRMatrix_SetMethods.F90
@@ -24,6 +24,7 @@ MODULE CSRMatrix_SetMethods
PUBLIC :: SetSingleValue
PUBLIC :: ASSIGNMENT(=)
PUBLIC :: SetIA, SetJA
+PUBLIC :: SetToSTMatrix
!----------------------------------------------------------------------------
! Set@setMethod
@@ -577,4 +578,38 @@ MODULE PURE SUBROUTINE obj_SetJA(obj, indx, VALUE)
END SUBROUTINE obj_SetJA
END INTERFACE SetJA
+!----------------------------------------------------------------------------
+! Set@setMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-12-17
+! summary: (Obj)ab = Value
+!
+!# Introduction
+!
+! In time discontinuous fem, tangent matrix is block matrix
+! First we assemble mass and stiffness matrix separately
+! they can be represented by Value.
+! Now we want to make one of the blocks of space-time matrix
+! which is represented by Obj.
+! This routine performs this task.
+! Note that the storage format of Obj should be FMT_DOF
+! Note that the storage format of Value and one of the blocks should be
+! identical.
+
+INTERFACE SetToSTMatrix
+ MODULE PURE SUBROUTINE obj_SetToSTMatrix1( &
+ obj, VALUE, itimecompo, jtimecompo, scale)
+ TYPE(CSRMatrix_), INTENT(INOUT) :: obj
+ !! space-time matrix, format should be FMT_DOF
+ TYPE(CSRMatrix_), INTENT(IN) :: VALUE
+ !! space matrix
+ INTEGER(I4B), INTENT(IN) :: itimecompo, jtimecompo
+ !! time components
+ REAL(DFP), OPTIONAL, INTENT(IN) :: scale
+ !! scale
+ END SUBROUTINE obj_SetToSTMatrix1
+END INTERFACE SetToSTMatrix
+
END MODULE CSRMatrix_SetMethods
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_AddMethods.F90 b/src/modules/DOF/src/DOF_AddMethods.F90
index b526b4189..14241de95 100644
--- a/src/modules/DOF/src/DOF_AddMethods.F90
+++ b/src/modules/DOF/src/DOF_AddMethods.F90
@@ -16,96 +16,100 @@
!
MODULE DOF_AddMethods
-USE GlobalData
-USE BaseType
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: RealVector_, DOF_
+
IMPLICIT NONE
PRIVATE
-PUBLIC :: add
+PUBLIC :: Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of all dof defined inside `obj`. Once
! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`.
-! - To tackle this `conversion` can be add to `DOFToNodes`, `NodesToDOF`
+! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF`
! or `NONE`.
!
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add1(vec, obj, nodenum, VALUE, scale, &
- & conversion)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add1(vec, obj, nodenum, VALUE, scale, &
+ conversion)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ !! Vector to set values in
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! degree of freedom object
INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! Node number
REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! Value
REAL(DFP), INTENT(IN) :: scale
+ !! scale
INTEGER(I4B), INTENT(IN) :: conversion(1)
- END SUBROUTINE dof_add1
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add1
-END INTERFACE add
+ !! conversion
+ END SUBROUTINE obj_Add1
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of all dof defined inside `obj`. Once
! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`.
-! - To tackle this `conversion` can be add to `DOFToNodes`, `NodesToDOF`
+! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF`
! or `NONE`.
!
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add2(vec, obj, nodenum, VALUE, scale)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add2(vec, obj, nodenum, VALUE, scale)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ !! vector to set values in
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! degree of freedom object
INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! node number
REAL(DFP), INTENT(IN) :: VALUE
+ !! scalar value
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE dof_add2
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add2
-END INTERFACE add
+ !! scale
+ END SUBROUTINE obj_Add2
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of dof `dofno`.
@@ -113,204 +117,193 @@ END SUBROUTINE dof_add2
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add3(vec, obj, nodenum, VALUE, scale, idof)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add3(vec, obj, nodenum, VALUE, scale, idof)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ !! vector to set values in
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! degree of freedom object
INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! node number
REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! vec = values, size of value should be equal to the size of nodenum
REAL(DFP), INTENT(IN) :: scale
+ !! scale
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE dof_add3
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add3
-END INTERFACE add
+ !! global degree of freedom number
+ END SUBROUTINE obj_Add3
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
+! This subroutine calls obj_Add3
-INTERFACE
- MODULE PURE SUBROUTINE dof_add4(vec, obj, nodenum, VALUE, scale, ivar, idof)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add4(vec, obj, nodenum, VALUE, scale, ivar, idof)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
- !! Object `obj` contains the storage pattern of degrees of freedom
- !! inside `vec`.
- !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
+ !! vector to set values in
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! Object `obj` contains the storage pattern of degrees of freedom
+ !! inside `vec`.
+ !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- !! node number
+ !! node number
REAL(DFP), INTENT(IN) :: VALUE(:)
- !! `value` denotes the nodal values of dof `idof`.
+ !! `value` denotes the nodal values of dof `idof`.
REAL(DFP), INTENT(IN) :: scale
- !! scale
+ !! scale
INTEGER(I4B), INTENT(IN) :: ivar
- !! physical variable
+ !! physical variable
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE dof_add4
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add4
-END INTERFACE add
+ END SUBROUTINE obj_Add4
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
+!
+!@note
+! this routine calls obj_Add3
+!@endnote
-INTERFACE
- MODULE PURE SUBROUTINE dof_add5(vec, obj, nodenum, VALUE, scale, ivar, &
- & spacecompo, timecompo)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add5(vec, obj, nodenum, VALUE, scale, ivar, &
+ spacecompo, timecompo)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
- !! Object `obj` contains the storage pattern of degrees of freedom
- !! inside `vec`.
- !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! Object `obj` contains the storage pattern of degrees of freedom
+ !! inside `vec`.
+ !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- !! node number
+ !! node number
REAL(DFP), INTENT(IN) :: VALUE(:)
- !! `value` denotes the nodal values of dof `idof`.
+ !! `value` denotes the nodal values of dof `idof`.
+ !! the size of value should be same as nodenum
REAL(DFP), INTENT(IN) :: scale
- !! scale
+ !! scale
INTEGER(I4B), INTENT(IN) :: ivar
- !! physical variable
+ !! physical variable
INTEGER(I4B), INTENT(IN) :: spacecompo
- !! space components
+ !! space components
INTEGER(I4B), INTENT(IN) :: timecompo
- !! time components
- END SUBROUTINE dof_add5
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add5
-END INTERFACE add
+ !! time components
+ END SUBROUTINE obj_Add5
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
-INTERFACE
- MODULE PURE SUBROUTINE dof_add6(vec, obj, nodenum, VALUE, scale, ivar, &
- & spacecompo, timecompo)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add6(vec, obj, nodenum, VALUE, scale, ivar, &
+ spacecompo, timecompo)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
- !! Object `obj` contains the storage pattern of degrees of freedom
- !! inside `vec`.
- !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! Object `obj` contains the storage pattern of degrees of freedom
+ !! inside `vec`.
+ !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- !! node number
+ !! node number
REAL(DFP), INTENT(IN) :: VALUE(:)
- !! `value` denotes the nodal values of dof `idof`.
+ !! `value` denotes the nodal values of dof `idof`.
REAL(DFP), INTENT(IN) :: scale
- !! scale
+ !! scale
INTEGER(I4B), INTENT(IN) :: ivar
- !! physical variable
+ !! physical variable
INTEGER(I4B), INTENT(IN) :: spacecompo
- !! space components
+ !! space components
INTEGER(I4B), INTENT(IN) :: timecompo(:)
- !! time components
- END SUBROUTINE dof_add6
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add6
-END INTERFACE add
+ !! time components
+ END SUBROUTINE obj_Add6
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
-INTERFACE
- MODULE PURE SUBROUTINE dof_add7(vec, obj, nodenum, VALUE, scale, ivar, &
- & spacecompo, timecompo)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add7(vec, obj, nodenum, VALUE, scale, ivar, &
+ spacecompo, timecompo)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
- !! Object `obj` contains the storage pattern of degrees of freedom
- !! inside `vec`.
- !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
+ TYPE(DOF_), INTENT(IN) :: obj
+ !! Object `obj` contains the storage pattern of degrees of freedom
+ !! inside `vec`.
+ !! This storage pattern can be `FMT_Nodes` or `FMT_DOF`
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- !! node number
+ !! node number
REAL(DFP), INTENT(IN) :: VALUE(:)
- !! `value` denotes the nodal values of dof `idof`.
+ !! `value` denotes the nodal values of dof `idof`.
REAL(DFP), INTENT(IN) :: scale
- !! scale
+ !! scale
INTEGER(I4B), INTENT(IN) :: ivar
- !! physical variable
+ !! physical variable
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
- !! space components
+ !! space components
INTEGER(I4B), INTENT(IN) :: timecompo
- !! time components
- END SUBROUTINE dof_add7
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add7
-END INTERFACE add
+ !! time components
+ END SUBROUTINE obj_Add7
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of all dof defined inside `obj`. Once
! storage pattern in `value` can be `FMT_DOF` or `FMT_Nodes`.
-! - To tackle this `conversion` can be add to `DOFToNodes`, `NodesToDOF`
+! - To tackle this `conversion` can be Add to `DOFToNodes`, `NodesToDOF`
! or `NONE`.
!
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add8(vec, obj, nodenum, VALUE, scale)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add8(vec, obj, nodenum, VALUE, scale)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE dof_add8
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add8
-END INTERFACE add
+ END SUBROUTINE obj_Add8
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of dof `dofno`.
@@ -318,32 +311,28 @@ END SUBROUTINE dof_add8
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add9(vec, obj, nodenum, VALUE, scale, idof)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add9(vec, obj, nodenum, VALUE, scale, idof)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE dof_add9
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add9
-END INTERFACE add
+ END SUBROUTINE obj_Add9
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of dof `dofno`.
@@ -351,34 +340,29 @@ END SUBROUTINE dof_add9
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add10(vec, obj, nodenum, VALUE, scale, &
- & ivar, idof)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add10(vec, obj, nodenum, VALUE, scale, ivar, idof)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE dof_add10
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add10
-END INTERFACE add
+ END SUBROUTINE obj_Add10
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of dof `dofno`.
@@ -386,35 +370,31 @@ END SUBROUTINE dof_add10
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add11(vec, obj, nodenum, VALUE, scale, &
- & ivar, spacecompo, timecompo)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add11(vec, obj, nodenum, VALUE, scale, &
+ ivar, spacecompo, timecompo)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE dof_add11
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add11
-END INTERFACE add
+ END SUBROUTINE obj_Add11
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of dof `dofno`.
@@ -422,35 +402,31 @@ END SUBROUTINE dof_add11
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add12(vec, obj, nodenum, VALUE, scale, &
- & ivar, spacecompo, timecompo)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add12(vec, obj, nodenum, VALUE, scale, &
+ ivar, spacecompo, timecompo)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo(:)
- END SUBROUTINE dof_add12
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add12
-END INTERFACE add
+ END SUBROUTINE obj_Add12
+END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethod
+! Add@addMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: add values in a vector of real numbers
+! summary: Add values in a vector of real numbers
!
!# Introduction
!
-! This subroutine is designed to add values in a vector of real number
+! This subroutine is designed to Add values in a vector of real number
! - [[DOF_]] object `obj` contains the storage pattern of degrees of freedom
! inside `vec`. This storage pattern can be `FMT_Nodes` or `FMT_DOF`
! - `value` denotes the nodal values of dof `dofno`.
@@ -458,22 +434,18 @@ END SUBROUTINE dof_add12
! This subroutine effectivily performes
! `vec( nptrs ) = vec(nptrs) + scale * value`
-INTERFACE
- MODULE PURE SUBROUTINE dof_add13(vec, obj, nodenum, VALUE, scale, &
- & ivar, spacecompo, timecompo)
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add13(vec, obj, nodenum, VALUE, scale, &
+ ivar, spacecompo, timecompo)
REAL(DFP), INTENT(INOUT) :: vec(:)
- CLASS(DOF_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE dof_add13
-END INTERFACE
-
-INTERFACE add
- MODULE PROCEDURE dof_add13
-END INTERFACE add
+ END SUBROUTINE obj_Add13
+END INTERFACE Add
END MODULE DOF_AddMethods
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/DOF/src/DOF_GetMethods.F90 b/src/modules/DOF/src/DOF_GetMethods.F90
index 448b75aeb..a81bd982e 100644
--- a/src/modules/DOF/src/DOF_GetMethods.F90
+++ b/src/modules/DOF/src/DOF_GetMethods.F90
@@ -1228,6 +1228,36 @@ MODULE PURE SUBROUTINE obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, &
END SUBROUTINE obj_GetNodeLoc_13
END INTERFACE GetNodeLoc_
+!----------------------------------------------------------------------------
+! GetNodeLoc_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-01
+! summary: This routine returns the location of node
+
+INTERFACE GetNodeLoc_
+ MODULE PURE SUBROUTINE obj_GetNodeLoc_14(obj, nodenum, idof, ans, nrow, &
+ ncol, storageFMT)
+ TYPE(DOF_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! node numbers
+ INTEGER(I4B), INTENT(IN) :: idof(:)
+ !! physical variable number
+ INTEGER(I4B), INTENT(INOUT) :: ans(:, :)
+ !! returned location of nodenum
+ INTEGER(I4B), INTENT(OUT) :: nrow
+ !! number of rows written in ans
+ INTEGER(I4B), INTENT(OUT) :: ncol
+ !! number of cols written in ans
+ INTEGER(I4B), INTENT(IN) :: storageFMT
+ !! if storageFMT is NODES_FMT, then
+ !! nrow is size(idofs) and ncol is size(nodenum)
+ !! if storageFMT is DOF_FMT, then
+ !! nrow is size(nodenum) and ncol is size(idofs)
+ END SUBROUTINE obj_GetNodeLoc_14
+END INTERFACE GetNodeLoc_
+
!----------------------------------------------------------------------------
! GetIndex
!----------------------------------------------------------------------------
diff --git a/src/modules/DOF/src/DOF_IOMethods.F90 b/src/modules/DOF/src/DOF_IOMethods.F90
index fee5e0a80..adaf5142a 100644
--- a/src/modules/DOF/src/DOF_IOMethods.F90
+++ b/src/modules/DOF/src/DOF_IOMethods.F90
@@ -16,8 +16,9 @@
!
MODULE DOF_IOMethods
-USE GlobalData
-USE BaseType
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: RealVector_, DOF_
+
IMPLICIT NONE
PRIVATE
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..7db090a23 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.
!----------------------------------------------------------------------------
@@ -62,51 +61,51 @@ MODULE Display_Method
INTERFACE Display
MODULE PROCEDURE &
- & Display_Str, &
- & Display_Str2, &
- & Display_Real64, &
- & Display_Real32, &
- & Display_Cmplx64, &
- & Display_Cmplx32, &
- & Display_Int8, &
- & Display_Int16, &
- & Display_Int32, &
- & Display_Int64, &
- & Display_Logical, &
- & Display_Vector_Logical, &
- & Display_Vector_Real64, &
- & Display_Vector_Real32, &
- & Display_Vector_Cmplx64, &
- & Display_Vector_Cmplx32, &
- & Display_Vector_Int8, &
- & Display_Vector_Int16, &
- & Display_Vector_Int32, &
- & Display_Vector_Int64, &
- & Display_Mat2_Real64, &
- & Display_Mat2_Real32, &
- & Display_Mat2_Cmplx64, &
- & Display_Mat2_Cmplx32, &
- & Display_Mat2_Int64, &
- & Display_Mat2_Int32, &
- & Display_Mat2_Int16, &
- & Display_Mat2_Int8, &
- & Display_Mat2_Bool, &
- & Display_Mat3_Real64, &
- & Display_Mat3_Real32, &
- & Display_Mat3_Cmplx64, &
- & Display_Mat3_Cmplx32, &
- & Display_Mat3_Int64, &
- & Display_Mat3_Int32, &
- & Display_Mat3_Int16, &
- & Display_Mat3_Int8, &
- & Display_Mat4_Real64, &
- & Display_Mat4_Real32, &
- & Display_Mat4_Cmplx64, &
- & Display_Mat4_Cmplx32, &
- & Display_Mat4_Int64, &
- & Display_Mat4_Int32, &
- & Display_Mat4_Int16, &
- & Display_Mat4_Int8
+ Display_Str, &
+ Display_Str2, &
+ Display_Real64, &
+ Display_Real32, &
+ Display_Cmplx64, &
+ Display_Cmplx32, &
+ Display_Int8, &
+ Display_Int16, &
+ Display_Int32, &
+ Display_Int64, &
+ Display_Logical, &
+ Display_Vector_Logical, &
+ Display_Vector_Real64, &
+ Display_Vector_Real32, &
+ Display_Vector_Cmplx64, &
+ Display_Vector_Cmplx32, &
+ Display_Vector_Int8, &
+ Display_Vector_Int16, &
+ Display_Vector_Int32, &
+ Display_Vector_Int64, &
+ Display_Mat2_Real64, &
+ Display_Mat2_Real32, &
+ Display_Mat2_Cmplx64, &
+ Display_Mat2_Cmplx32, &
+ Display_Mat2_Int64, &
+ Display_Mat2_Int32, &
+ Display_Mat2_Int16, &
+ Display_Mat2_Int8, &
+ Display_Mat2_Bool, &
+ Display_Mat3_Real64, &
+ Display_Mat3_Real32, &
+ Display_Mat3_Cmplx64, &
+ Display_Mat3_Cmplx32, &
+ Display_Mat3_Int64, &
+ Display_Mat3_Int32, &
+ Display_Mat3_Int16, &
+ Display_Mat3_Int8, &
+ Display_Mat4_Real64, &
+ Display_Mat4_Real32, &
+ Display_Mat4_Cmplx64, &
+ Display_Mat4_Cmplx32, &
+ Display_Mat4_Int64, &
+ Display_Mat4_Int32, &
+ Display_Mat4_Int16, &
+ Display_Mat4_Int8
END INTERFACE
CONTAINS
@@ -267,7 +266,7 @@ SUBROUTINE Display_Real64(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Real64
!----------------------------------------------------------------------------
@@ -294,7 +293,7 @@ SUBROUTINE Display_Real32(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Real32
!----------------------------------------------------------------------------
@@ -317,7 +316,7 @@ SUBROUTINE Display_Cmplx64(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Cmplx64
!----------------------------------------------------------------------------
@@ -340,7 +339,7 @@ SUBROUTINE Display_Cmplx32(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Cmplx32
!----------------------------------------------------------------------------
@@ -367,7 +366,7 @@ SUBROUTINE Display_Int64(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Int64
!----------------------------------------------------------------------------
@@ -394,7 +393,7 @@ SUBROUTINE Display_Int32(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Int32
!----------------------------------------------------------------------------
@@ -421,7 +420,7 @@ SUBROUTINE Display_Int16(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Int16
!----------------------------------------------------------------------------
@@ -448,7 +447,7 @@ SUBROUTINE Display_Int8(val, msg, unitNo, advance)
CHARACTER(*), INTENT(IN) :: msg
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Scalar.inc"
+#include "./include/Display_Scalar.F90"
END SUBROUTINE Display_Int8
!----------------------------------------------------------------------------
@@ -531,7 +530,7 @@ SUBROUTINE Display_Vector_Logical(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Logical
!----------------------------------------------------------------------------
@@ -569,7 +568,7 @@ SUBROUTINE Display_Vector_Real64(val, msg, unitNo, orient, full, advance)
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
!! vector of real numbers
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Real64
!----------------------------------------------------------------------------
@@ -606,7 +605,7 @@ SUBROUTINE Display_Vector_Real32(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Real32
!----------------------------------------------------------------------------
@@ -644,7 +643,7 @@ SUBROUTINE Display_Vector_Cmplx64(val, msg, unitNo, orient, full, advance)
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
!! vector of real numbers
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Cmplx64
!----------------------------------------------------------------------------
@@ -681,7 +680,7 @@ SUBROUTINE Display_Vector_Cmplx32(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Cmplx32
!----------------------------------------------------------------------------
@@ -719,7 +718,7 @@ SUBROUTINE Display_Vector_Int32(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Int32
!----------------------------------------------------------------------------
@@ -757,7 +756,7 @@ SUBROUTINE Display_Vector_Int64(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Int64
!----------------------------------------------------------------------------
@@ -794,7 +793,7 @@ SUBROUTINE Display_Vector_Int16(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Int16
!----------------------------------------------------------------------------
@@ -831,7 +830,7 @@ SUBROUTINE Display_Vector_Int8(val, msg, unitNo, orient, full, advance)
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
! logical variable to print the whole vector
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Vector.inc"
+#include "./include/Display_Vector.F90"
END SUBROUTINE Display_Vector_Int8
!----------------------------------------------------------------------------
@@ -858,7 +857,7 @@ SUBROUTINE Display_Mat2_Real64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Real64
!----------------------------------------------------------------------------
@@ -885,7 +884,7 @@ SUBROUTINE Display_Mat2_Real32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Real32
!----------------------------------------------------------------------------
@@ -913,7 +912,7 @@ SUBROUTINE Display_Mat2_Cmplx64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Cmplx64
!----------------------------------------------------------------------------
@@ -941,7 +940,7 @@ SUBROUTINE Display_Mat2_Cmplx32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Cmplx32
!----------------------------------------------------------------------------
@@ -966,7 +965,7 @@ SUBROUTINE Display_Mat2_Int64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Int64
!----------------------------------------------------------------------------
@@ -991,7 +990,7 @@ SUBROUTINE Display_Mat2_Int32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Int32
!----------------------------------------------------------------------------
@@ -1016,7 +1015,7 @@ SUBROUTINE Display_Mat2_Int16(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Int16
!----------------------------------------------------------------------------
@@ -1041,7 +1040,7 @@ SUBROUTINE Display_Mat2_Int8(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Int8
!----------------------------------------------------------------------------
@@ -1066,7 +1065,7 @@ SUBROUTINE Display_Mat2_Bool(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), INTENT(IN), OPTIONAL :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat2.inc"
+#include "./include/Display_Mat2.F90"
END SUBROUTINE Display_Mat2_Bool
!----------------------------------------------------------------------------
@@ -1095,7 +1094,7 @@ SUBROUTINE Display_Mat3_Real64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Real64
!----------------------------------------------------------------------------
@@ -1124,7 +1123,7 @@ SUBROUTINE Display_Mat3_Real32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Real32
!----------------------------------------------------------------------------
@@ -1154,7 +1153,7 @@ SUBROUTINE Display_Mat3_Cmplx64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Cmplx64
!----------------------------------------------------------------------------
@@ -1184,7 +1183,7 @@ SUBROUTINE Display_Mat3_Cmplx32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Cmplx32
!----------------------------------------------------------------------------
@@ -1213,7 +1212,7 @@ SUBROUTINE Display_Mat3_Int64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Int64
!----------------------------------------------------------------------------
@@ -1242,7 +1241,7 @@ SUBROUTINE Display_Mat3_Int32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Int32
!----------------------------------------------------------------------------
@@ -1272,7 +1271,7 @@ SUBROUTINE Display_Mat3_Int16(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Int16
!----------------------------------------------------------------------------
@@ -1302,7 +1301,7 @@ SUBROUTINE Display_Mat3_Int8(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat3.inc"
+#include "./include/Display_Mat3.F90"
END SUBROUTINE Display_Mat3_Int8
!----------------------------------------------------------------------------
@@ -1332,7 +1331,7 @@ SUBROUTINE Display_Mat4_Real64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Real64
!----------------------------------------------------------------------------
@@ -1362,7 +1361,7 @@ SUBROUTINE Display_Mat4_Real32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Real32
!----------------------------------------------------------------------------
@@ -1393,7 +1392,7 @@ SUBROUTINE Display_Mat4_Cmplx64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Cmplx64
!----------------------------------------------------------------------------
@@ -1423,7 +1422,7 @@ SUBROUTINE Display_Mat4_Cmplx32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Cmplx32
!----------------------------------------------------------------------------
@@ -1453,7 +1452,7 @@ SUBROUTINE Display_Mat4_Int64(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Int64
!----------------------------------------------------------------------------
@@ -1483,7 +1482,7 @@ SUBROUTINE Display_Mat4_Int32(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Int32
!----------------------------------------------------------------------------
@@ -1513,7 +1512,7 @@ SUBROUTINE Display_Mat4_Int16(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Int16
!----------------------------------------------------------------------------
@@ -1543,7 +1542,7 @@ SUBROUTINE Display_Mat4_Int8(Val, msg, unitNo, full, advance)
INTEGER(I4B), INTENT(IN), OPTIONAL :: unitNo
LOGICAL(LGT), OPTIONAL, INTENT(IN) :: full
CHARACTER(*), OPTIONAL, INTENT(IN) :: advance
-#include "./Display_Mat4.inc"
+#include "./include/Display_Mat4.F90"
END SUBROUTINE Display_Mat4_Int8
!----------------------------------------------------------------------------
@@ -1709,4 +1708,9 @@ SUBROUTINE TIMESTAMP()
d, TRIM(month(m)), y, h, ':', n, ':', s, '.', mm, TRIM(ampm)
END SUBROUTINE TIMESTAMP
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE Display_Method
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/Display/src/Display_Mat2.inc b/src/modules/Display/src/include/Display_Mat2.F90
similarity index 100%
rename from src/modules/Display/src/Display_Mat2.inc
rename to src/modules/Display/src/include/Display_Mat2.F90
diff --git a/src/modules/Display/src/Display_Mat3.inc b/src/modules/Display/src/include/Display_Mat3.F90
similarity index 100%
rename from src/modules/Display/src/Display_Mat3.inc
rename to src/modules/Display/src/include/Display_Mat3.F90
diff --git a/src/modules/Display/src/Display_Mat4.inc b/src/modules/Display/src/include/Display_Mat4.F90
similarity index 100%
rename from src/modules/Display/src/Display_Mat4.inc
rename to src/modules/Display/src/include/Display_Mat4.F90
diff --git a/src/modules/Display/src/Display_Scalar.inc b/src/modules/Display/src/include/Display_Scalar.F90
similarity index 100%
rename from src/modules/Display/src/Display_Scalar.inc
rename to src/modules/Display/src/include/Display_Scalar.F90
diff --git a/src/modules/Display/src/Display_Vector.inc b/src/modules/Display/src/include/Display_Vector.F90
similarity index 57%
rename from src/modules/Display/src/Display_Vector.inc
rename to src/modules/Display/src/include/Display_Vector.F90
index 897509be8..8b087060c 100644
--- a/src/modules/Display/src/Display_Vector.inc
+++ b/src/modules/Display/src/include/Display_Vector.F90
@@ -19,55 +19,52 @@
CHARACTER(3) :: orient_
LOGICAL(LGT) :: full_
INTEGER(I4B) :: ii, ff, ss
+LOGICAL(LGT) :: isok, abool
CALL setDefaultSettings
!> main
-IF (PRESENT(unitNo)) THEN
- I = unitNo
-ELSE
- I = stdout
-END IF
-IF (PRESENT(full)) THEN
- full_ = full
-ELSE
- full_ = .FALSE.
- ! do nothing for now
-END IF
-IF (I .NE. stdout .OR. (I .NE. stderr)) THEN
- full_ = .TRUE.
-END IF
+I = stdout
+full_ = .FALSE.
+orient_ = "col"
-IF (PRESENT(orient)) THEN
- IF (orient(1:1) .EQ. "r" .OR. orient(1:1) .EQ. "R") THEN
- orient_ = "row"
- ELSE
- orient_ = "col"
- END IF
-ELSE
- orient_ = "col"
+isok = PRESENT(unitNo); IF (isok) I = unitNo
+isok = PRESENT(full); IF (isok) full_ = full
+isok = (I .NE. stdout) .OR. (I .NE. stderr)
+IF (isok) full_ = .TRUE.
+
+isok = PRESENT(orient)
+IF (isok) THEN
+ abool = (orient(1:1) .EQ. "r") .OR. (orient(1:1) .EQ. "R")
+ IF (abool) orient_ = "row"
END IF
ss = SIZE(val)
-IF (full_ .OR. ss .LE. (minRow + minRow)) THEN
+abool = ss .LE. (minRow + minRow)
+IF (full_ .OR. abool) THEN
+
#ifdef COLOR_DISP
CALL DISP( &
- & title=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, &
- & style=COLOR_STYLE)), &
- & x=val, unit=I, orient=orient_, advance=advance)
+ title=TRIM(colorize(msg, color_fg=COLOR_FG, color_bg=COLOR_BG, &
+ style=COLOR_STYLE)), &
+ x=val, unit=I, orient=orient_, advance=advance)
#else
CALL DISP(title=msg, x=val, unit=I, orient=orient_, advance=advance)
#endif
+
ELSE
IF (orient_ .EQ. "row") THEN
CALL Disp(title=msg, unit=I, advance="YES")
- CALL DISP(title="", x=val(1:minRow), unit=I, orient=orient_, advance="NO")
+ CALL Disp(title="", x=val(1:minRow), unit=I, orient=orient_, advance="NO")
CALL Display("...", unitNo=I, advance=.FALSE.)
- CALL DISP(title="", x=val(ss-minRow+1:ss), unit=I, orient=orient_, advance=advance)
+ CALL Disp(title="", x=val(ss - minRow + 1:ss), unit=I, orient=orient_, &
+ advance=advance)
ELSE
CALL Disp(title=msg, unit=I, advance="YES")
- CALL DISP(title="", x=val(1:minRow), unit=I, orient=orient_, advance="YES")
+ CALL Disp(title="", x=val(1:minRow), unit=I, orient=orient_, &
+ advance="YES")
CALL Display("."//CHAR_LF//"."//CHAR_LF//".", unitNo=I, advance=.TRUE.)
- CALL DISP(title="", x=val(ss-minRow+1:ss), unit=I, orient=orient_, advance=advance)
+ CALL Disp(title="", x=val(ss - minRow + 1:ss), unit=I, orient=orient_, &
+ advance=advance)
END IF
END IF
diff --git a/src/modules/ElemshapeData/CMakeLists.txt b/src/modules/ElemshapeData/CMakeLists.txt
index 39fa1ba47..85dc0942c 100644
--- a/src/modules/ElemshapeData/CMakeLists.txt
+++ b/src/modules/ElemshapeData/CMakeLists.txt
@@ -1,43 +1,46 @@
-# 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_ScalarInterpolMethods.F90
+ ${src_path}/ElemshapeData_VectorInterpolMethods.F90
+ ${src_path}/ElemshapeData_MatrixInterpolMethods.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..4f84eef0d 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_ConstructorMethods.F90
@@ -16,8 +16,9 @@
!
MODULE ElemshapeData_ConstructorMethods
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, QuadraturePoint_, &
+ ReferenceElement_
+USE GlobalData, ONLY: I4B, DFP, LGT
IMPLICIT NONE
PRIVATE
@@ -40,7 +41,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 obj_Allocate(obj, nsd, xidim, nns, nips, nnt)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! object to be returned
INTEGER(I4B), INTENT(IN) :: nsd
@@ -51,20 +52,26 @@ MODULE PURE SUBROUTINE elemsd_Allocate(obj, nsd, xidim, nns, nips)
!! number of nodes in element
INTEGER(I4B), INTENT(IN) :: nips
!! number of integration points
- END SUBROUTINE elemsd_Allocate
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: nnt
+ !! it is used when elemshape data is STElemShapeData
+ END SUBROUTINE obj_Allocate
END INTERFACE ALLOCATE
+INTERFACE Initiate
+ MODULE PROCEDURE obj_Allocate
+END INTERFACE Initiate
+
!----------------------------------------------------------------------------
! Initiate@ConstructorMethods
!----------------------------------------------------------------------------
!> 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 obj_Initiate1(obj, quad, refelem, continuityType, &
+ interpolType)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
!! ElemshapeData to be formed
CLASS(QuadraturePoint_), INTENT(IN) :: quad
@@ -75,7 +82,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 obj_Initiate1
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -87,85 +94,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
-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
+ MODULE SUBROUTINE obj_Initiate2(obj1, obj2)
+ CLASS(ElemshapeData_), INTENT(INOUT) :: obj1
+ CLASS(ElemshapeData_), INTENT(IN) :: obj2
+ END SUBROUTINE obj_Initiate2
END INTERFACE Initiate
INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE elemsd_initiate5
+ MODULE PROCEDURE obj_Initiate2
END INTERFACE
!----------------------------------------------------------------------------
@@ -178,7 +114,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 +130,11 @@ END SUBROUTINE elemsd_initiate5
!
INTERFACE Initiate
- MODULE PURE SUBROUTINE stsd_initiate(obj, elemsd)
+ MODULE PURE SUBROUTINE obj_Initiate3(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 obj_Initiate3
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -216,9 +152,9 @@ END SUBROUTINE stsd_initiate
!
INTERFACE DEALLOCATE
- MODULE PURE SUBROUTINE elemsd_Deallocate(obj)
+ MODULE PURE SUBROUTINE obj_Deallocate(obj)
CLASS(ElemshapeData_), INTENT(INOUT) :: obj
- END SUBROUTINE elemsd_Deallocate
+ END SUBROUTINE obj_Deallocate
END INTERFACE DEALLOCATE
END MODULE ElemshapeData_ConstructorMethods
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..2258d1958 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,9 @@ 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 +87,9 @@ 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 +125,9 @@ 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 +159,9 @@ 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..9c83a8d71
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Hierarchical.F90
@@ -0,0 +1,184 @@
+! 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 :: HierarchicalFacetElemShapeData
+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
+
+!----------------------------------------------------------------------------
+! Initiate@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE HierarchicalFacetElemShapeData
+ MODULE SUBROUTINE HierarchicalFacetElemShapeData1( &
+ obj, facetElemsd, quad, facetQuad, localFaceNumber, nsd, xidim, &
+ elemType, refelemCoord, domainName, cellOrder, faceOrder, edgeOrder, &
+ cellOrient, faceOrient, edgeOrient)
+ TYPE(ElemshapeData_), INTENT(INOUT) :: obj, facetElemsd
+ !! element shape data
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad, facetQuad
+ !! quadrature point
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ 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) :: cellOrder(:)
+ !! cell order, always needed
+ INTEGER(I4B), INTENT(IN) :: faceOrder(:, :)
+ !! face order, needed for 2D and 3D elements
+ INTEGER(I4B), INTENT(IN) :: edgeOrder(:)
+ !! edge order, needed for 3D elements only
+ INTEGER(I4B), INTENT(IN) :: cellOrient(:)
+ !! orientation of cell
+ INTEGER(I4B), INTENT(IN) :: faceOrient(:, :)
+ !! orientation of face
+ INTEGER(I4B), INTENT(IN) :: edgeOrient(:)
+ !! edge orientation
+ END SUBROUTINE HierarchicalFacetElemShapeData1
+END INTERFACE HierarchicalFacetElemShapeData
+
+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..b76509037 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_InterpolMethods.F90
@@ -17,456 +17,165 @@
!
! This file contains the interpolation methods interfaces\
-module ElemshapeData_InterpolMethods
-USE BaseType
-USE GlobalData
+MODULE ElemshapeData_InterpolMethods
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_
IMPLICIT NONE
PRIVATE
-PUBLIC :: getInterpolation
+PUBLIC :: GetInterpolation_
+PUBLIC :: GetInterpolation
PUBLIC :: Interpolation
-PUBLIC :: STInterpolation
!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
+! GetInterpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 4 March 2021
-! summary: This subroutine performs interpolations of scalar
-!
-!# Introduction
-!
-! This subroutine performs interpolation of a scalar from its spatial nodal
-! values.
-!
-! $$u=u_{I}N^{I}$$
-!
-! - TODO Make it work when the size of val is not the same as NNS
-
-INTERFACE
- MODULE PURE SUBROUTINE scalar_getInterpolation_1(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:)
- !! Interpolation value of of scalar
- REAL(DFP), INTENT(IN) :: val(:)
- !! spatial nodal values of scalar
- END SUBROUTINE scalar_getInterpolation_1
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_1
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolations of scalar nodal values
-!
-!# Introduction
-!
-! This subroutine performs interpolation of a scalar from its space-time nodal
-! values.
-!
-! $$u=u^{a}_{I}N^{I}T_{a}$$
-!
-! The resultant represents the interpolation value of `val` at
-! spatial-quadrature points
-
-INTERFACE
- MODULE PURE SUBROUTINE scalar_getInterpolation_2(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:)
- !! Interpolation of scalar
- REAL(DFP), INTENT(IN) :: val(:, :)
- !! space-time nodal values of scalar
- END SUBROUTINE scalar_getInterpolation_2
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_2
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolations of scalar nodal values
+! summary: returns the interpolation of a FEVariable
!
!# Introduction
!
-! This subroutine performs interpolation of a scalar from its space-time nodal
-! values.
+! If ans is not initiated then it will be initiated
+! If ans is initiated then we will just call GetInterpolation_
+! which does not alter the properties of ans, it just fills the
+! value of ans
!
-! $$u=u^{a}_{I}N^{I}T_{a}$$
+! - Returns the interpolation of a FEVariable_
+! - The result is returned in ans, which is a FEVariable
+! - The rank of ans is same as the rank of val
+! - ans is defined on Quadrature, that is, ans is QuadratureVariable
+! - ans will vary in space only
!
-! The resultant represents the interpolation value of `val` at
-! spatial-temporal quadrature points
-
-INTERFACE
- MODULE PURE SUBROUTINE scalar_getInterpolation_3(obj, interpol, val)
- CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :)
- !! space-time Interpolation of scalar
- REAL(DFP), INTENT(IN) :: val(:, :)
- !! space-time nodal values of scalar
- END SUBROUTINE scalar_getInterpolation_3
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_3
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
-! summary: returns the interpolation of scalar FEVariable
-!
-!# Introduction
-!
-! Returns the interpolation of scalar variable
-! The scalar variable can be+
-!
-! - constant
-! - spatial nodal values
-! - spatial quadrature values
-! - space-time nodal values
+! - The val can have following ranks; scalar, vector, matrix
+! - the val can be defined on quadrature (do nothing) or nodal (interpol)
+! - The `vartype` of val can be constant, space, time, spacetime
!
-!@note
-!This routine calls [[Interpolation]] function from the same module.
-!@endnote
+! - If ans is not initiated then it will be initiated and then we will call
+! GetInterpolation_. In this case following properties are set for ans
+! - rank of ans and rank of val will be same
+! - vartype of ans will Space (We cannot set spacetime or time as
+! we do not have time shape function for
+! all quadrature points in time in obj)
INTERFACE
- MODULE PURE SUBROUTINE scalar_getInterpolation_4(obj, interpol, val)
+ MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:)
- !! interpolation of scalar
- TYPE(FEVariable_), INTENT(IN) :: val
- !! Scalar FE variable
- END SUBROUTINE scalar_getInterpolation_4
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_4
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolations of scalar FEVariable
-!
-!# Introduction
-!
-! This subroutine performs interpolation of a scalar [[FEVariable_]]
-! The FE Variable can be a
-!
-! - constant
-! - spatial nodal values
-! - spatial quadrature values
-! - space-time nodal values
-!
-! $$u=u^{a}_{I}N^{I}T_{a}$$
-!
-! The resultant represents the interpolation value of `val` at
-! spatial-quadrature points
-
-INTERFACE
- MODULE PURE SUBROUTINE scalar_getInterpolation_5(obj, interpol, val)
- CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :)
- !! space-time interpolation of scalar
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
TYPE(FEVariable_), INTENT(IN) :: val
- !! scalar FE variable
- END SUBROUTINE scalar_getInterpolation_5
+ END SUBROUTINE GetInterpolation1
END INTERFACE
-INTERFACE getInterpolation
- MODULE PROCEDURE scalar_getInterpolation_5
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation
+ MODULE PROCEDURE GetInterpolation1
+END INTERFACE GetInterpolation
!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
+! GetInterpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 4 March 2021
-! summary: This subroutine performs interpolation of a vector
-!
-!# Introduction
-!
-! This subroutine performs interpolation of a vector from its spatial
-! nodal values
-!
-! $$u_{i}=u_{iI}N^{I}$$
-
-INTERFACE
- MODULE PURE SUBROUTINE vector_getInterpolation_1(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :)
- !! interpolation of vector
- REAL(DFP), INTENT(IN) :: val(:, :)
- !! nodal values of vector in `xiJ` format
- END SUBROUTINE vector_getInterpolation_1
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_1
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolation of a vector
-!
-!# Introduction
-!
-! This subroutine performs interpolation of a vector from its space-time
-! nodal values
-!
-! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$
-
-INTERFACE
- MODULE PURE SUBROUTINE vector_getInterpolation_2(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :)
- !!
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- !! space-time nodal values of vector in `xiJa` format
- END SUBROUTINE vector_getInterpolation_2
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_2
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolation of a vector
+! summary: returns the interpolation of a FEVariable
!
!# Introduction
!
-! This subroutine performs interpolation of a vector from its space-time
-! nodal values
+! - Returns the interpolation of a FEVariable_
+! - The result is returned in ans
+! - ans is a FEVariable
+! - The rank of ans is same as the rank of val
+! - ans is defined on Quadrature, that is, ans is QuadratureVariable
!
-! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$
+! - The val can have following ranks; scalar, vector, matrix
+! - the val can be defined on quadrature (do nothing) or nodal (interpol)
+! - The `vartype` of val can be constant, space, time, spacetime
INTERFACE
- MODULE PURE SUBROUTINE vector_getInterpolation_3(obj, interpol, val)
- CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :)
- !!
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- !! space-time nodal values of vector in `xiJa` format
- END SUBROUTINE vector_getInterpolation_3
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_3
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
-! summary: returns the interpolation of vector FEVariable
-!
-!# Introduction
-!
-! Returns the interpolation of vector variable
-! The vector variable can be+
-!
-! - constant
-! - spatial nodal values
-! - spatial quadrature values
-! - space-time nodal values
-!
-! NOTE This routine calls [[Interpolation]] function from the same module.
-!
-INTERFACE
- MODULE PURE SUBROUTINE vector_getInterpolation_4(obj, interpol, val)
+ MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :)
- !! interpolation of vector
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
TYPE(FEVariable_), INTENT(IN) :: val
- !! vector FEvariable
- END SUBROUTINE vector_getInterpolation_4
+ END SUBROUTINE GetInterpolation_1
END INTERFACE
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_4
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation_
+ MODULE PROCEDURE GetInterpolation_1
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
+! GetInterpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 4 March 2021
-! summary: returns the interpolation of vector FEVariable
+! summary: returns the interpolation of a FEVariable
!
!# Introduction
!
-! Returns the interpolation of vector variable
-! The vector variable can be+
+! - Returns the interpolation of a FEVariable_
+! - The result is returned in ans
+! - ans is a FEVariable
+! - The rank of ans is same as the rank of val
+! - ans is defined on Quadrature, that is, ans is QuadratureVariable
!
-! - constant
-! - spatial nodal values
-! - spatial quadrature values
-! - space-time nodal values
-!
-! NOTE This routine calls [[Interpolation]] function from the same module.
+! - The val can have following ranks; scalar, vector, matrix
+! - the val can be defined on quadrature (do nothing) or nodal (interpol)
+! - The `vartype` of val can be constant, space, time, spacetime
!
INTERFACE
- MODULE PURE SUBROUTINE vector_getInterpolation_5(obj, interpol, val)
- CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :)
- !! space-time interpolation of vector
+ MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, scale, &
+ addContribution)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
TYPE(FEVariable_), INTENT(IN) :: val
- !! vector FEvariable
- END SUBROUTINE vector_getInterpolation_5
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL, INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_1a
END INTERFACE
-INTERFACE getInterpolation
- MODULE PROCEDURE vector_getInterpolation_5
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation_
+ MODULE PROCEDURE GetInterpolation_1a
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
+! GetInterpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 4 March 2021
-! summary: This subroutine performs interpolation of matrix
-
-INTERFACE
- MODULE PURE SUBROUTINE matrix_getInterpolation_1(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :)
- !! interpolation of matrix
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- !! nodal value of matrix
- END SUBROUTINE matrix_getInterpolation_1
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_1
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolation of matrix
+! summary: returns the interpolation of a FEVariable
!
!# Introduction
!
-! This subroutine performs interpolation of matrix from its space-time
-! nodal values
-
-INTERFACE
- 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
-
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_2
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 1 Nov 2021
-! summary: This subroutine performs interpolation of matrix
+! If ans is not initiated then it will be initiated. If
+! ans is initiated then its properties will not be altered.
!
-!# Introduction
+! - Returns the interpolation of a FEVariable
+! - The result is returned in ans, which is a FEVariable
+! - The rank of ans is same as the rank of val
+! - ans is defined on Quadrature, that is, ans is QuadratureVariable
!
-! This subroutine performs interpolation of matrix from its space-time
-! nodal values
-
-INTERFACE
- MODULE PURE SUBROUTINE matrix_getInterpolation_3(obj, interpol, val)
- CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), INTENT(INOUT), ALLOCATABLE :: interpol(:, :, :, :)
- !! space-time interpolation
- 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
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
-! summary: This subroutine performs interpolation of matrix FEVariable
+! - The val can have following ranks; scalar, vector, matrix
+! - the val can be defined on quadrature (do nothing) or nodal (interpol)
+! - The `vartype` of val can be constant, space, time, spacetime
!
-INTERFACE
- MODULE PURE SUBROUTINE matrix_getInterpolation_4(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :)
- !! interpolation of matrix
- TYPE(FEVariable_), INTENT(IN) :: val
- !! matrix fe variable
- END SUBROUTINE matrix_getInterpolation_4
-END INTERFACE
-
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_4
-END INTERFACE getInterpolation
-
-!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
+! - ans will Quadrature and SpaceTime
INTERFACE
- MODULE PURE SUBROUTINE matrix_getInterpolation_5(obj, interpol, val)
+ MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: interpol(:, :, :, :)
- !! space-time interpolation of matrix
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
TYPE(FEVariable_), INTENT(IN) :: val
- !! matrix fe variable
- END SUBROUTINE matrix_getInterpolation_5
+ END SUBROUTINE GetInterpolation2
END INTERFACE
-INTERFACE getInterpolation
- MODULE PROCEDURE matrix_getInterpolation_5
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation
+ MODULE PROCEDURE GetInterpolation2
+END INTERFACE GetInterpolation
!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
+! GetInterpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -486,111 +195,54 @@ END SUBROUTINE matrix_getInterpolation_5
! - The `vartype` of val can be constant, space, time, spacetime
!
INTERFACE
- MODULE PURE SUBROUTINE master_getInterpolation_1(obj, interpol, val)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- TYPE(FEVariable_), INTENT(INOUT) :: interpol
+ MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
TYPE(FEVariable_), INTENT(IN) :: val
- END SUBROUTINE master_getInterpolation_1
+ END SUBROUTINE GetInterpolation_2
END INTERFACE
-INTERFACE getInterpolation
- MODULE PROCEDURE master_getInterpolation_1
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation_
+ MODULE PROCEDURE GetInterpolation_2
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
-! getInterpolation@InterpolMethods
+! GetInterpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
+! date: 2025-09-01
! summary: returns the interpolation of a FEVariable
!
!# Introduction
!
-! - Returns the interpolation of a [[fevariable_]]
-! - The result is returned in interpol
-! - interpol is a FEVariable
-! - The rank of interpol is same as the rank of val
-! - interpol is defined on Quadrature, that is, interpol is QuadratureVariable
+! - Returns the interpolation of a FEVariable_
+! - The result is returned in ans
+! - ans is a FEVariable
+! - The rank of ans is same as the rank of val
+! - ans is defined on Quadrature, that is, ans is QuadratureVariable
!
! - The val can have following ranks; scalar, vector, matrix
! - the val can be defined on quadrature (do nothing) or nodal (interpol)
! - The `vartype` of val can be constant, space, time, spacetime
-!
+
INTERFACE
- MODULE PURE SUBROUTINE master_getInterpolation_2(obj, interpol, val)
+ MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, scale, &
+ addContribution)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- TYPE(FEVariable_), INTENT(INOUT) :: interpol
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
TYPE(FEVariable_), INTENT(IN) :: val
- END SUBROUTINE master_getInterpolation_2
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL, INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_2a
END INTERFACE
-INTERFACE getInterpolation
- MODULE PROCEDURE master_getInterpolation_2
-END INTERFACE getInterpolation
+INTERFACE GetInterpolation_
+ MODULE PROCEDURE GetInterpolation_2a
+END INTERFACE GetInterpolation_
!----------------------------------------------------------------------------
-! Interpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
-! summary: This function returns the interpolation of a scalar
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Interpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
-! summary: This function returns the interpolation of vector
-
-INTERFACE
- MODULE PURE FUNCTION vector_interpolation_1(obj, val) RESULT(interpol)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :)
- REAL(DFP), ALLOCATABLE :: interpol(:, :)
- END FUNCTION vector_interpolation_1
-END INTERFACE
-
-INTERFACE Interpolation
- MODULE PROCEDURE vector_interpolation_1
-END INTERFACE Interpolation
-
-!----------------------------------------------------------------------------
-! Interpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 4 March 2021
-! summary: This function returns the interpolation of matrix
-
-INTERFACE
- MODULE PURE FUNCTION matrix_interpolation_1(obj, val) RESULT(interpol)
- CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- REAL(DFP), ALLOCATABLE :: interpol(:, :, :)
- END FUNCTION matrix_interpolation_1
-END INTERFACE
-
-INTERFACE Interpolation
- MODULE PROCEDURE matrix_interpolation_1
-END INTERFACE Interpolation
-
-!----------------------------------------------------------------------------
-! Interpolation@InterpolMethods
+! Interpolation@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -599,97 +251,15 @@ END FUNCTION matrix_interpolation_1
! summary: Interpolation of FEVariable
INTERFACE
- MODULE PURE FUNCTION master_interpolation_1(obj, val) RESULT(Ans)
+ MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: obj
TYPE(FEVariable_), INTENT(IN) :: val
TYPE(FEVariable_) :: ans
- END FUNCTION master_interpolation_1
+ END FUNCTION Interpolation1
END INTERFACE
INTERFACE Interpolation
- MODULE PROCEDURE master_interpolation_1
+ MODULE PROCEDURE Interpolation1
END INTERFACE Interpolation
-!----------------------------------------------------------------------------
-! STInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-11-23
-! update: 2021-11-23
-! summary: This function performs interpolations of scalar
-!
-!# Introduction
-!
-! This function performs interpolation of a scalar from its space-time nodal
-! values.
-!
-! $$u=u^{a}_{I}N^{I}T_{a}$$
-
-INTERFACE
- MODULE PURE FUNCTION scalar_stinterpolation_1(obj, val) RESULT(interpol)
- CLASS(STElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :)
- !! space-time nodal values of scalar
- REAL(DFP), ALLOCATABLE :: interpol(:)
- !! Interpolation value of `val` at integration points
- END FUNCTION scalar_stinterpolation_1
-END INTERFACE
-
-INTERFACE STInterpolation
- MODULE PROCEDURE scalar_stinterpolation_1
-END INTERFACE STInterpolation
-
-!----------------------------------------------------------------------------
-! STInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-INTERFACE
-!! This function performs interpolations of vector
-
-!> author: Dr. Vikas Sharma
-!
-! This function performs interpolation of a vector from its space-time nodal
-! values.
-! $$u=u^{a}_{I}N^{I}T_{a}$$
-
- MODULE PURE FUNCTION vector_stinterpolation_1(obj, val) RESULT(interpol)
- CLASS(STElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- !! spatial nodal values of vector
- REAL(DFP), ALLOCATABLE :: interpol(:, :)
- !! Interpolation value of vector
- END FUNCTION vector_stinterpolation_1
-END INTERFACE
-
-INTERFACE STInterpolation
- MODULE PROCEDURE vector_stinterpolation_1
-END INTERFACE STInterpolation
-
-!----------------------------------------------------------------------------
-! STInterpolation@InterpolMethods
-!----------------------------------------------------------------------------
-
-INTERFACE
-!! This function performs interpolations of matrix
-
-!> author: Dr. Vikas Sharma
-!
-! This function performs interpolation of a matrix from its space-time nodal
-! values.
-! $$u=u^{a}_{I}N^{I}T_{a}$$
-
- MODULE PURE FUNCTION matrix_stinterpolation_1(obj, val) RESULT(interpol)
- CLASS(STElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :, :)
- !! spatial nodal values of matrix
- REAL(DFP), ALLOCATABLE :: interpol(:, :, :)
- !! Interpolation value of matrix
- END FUNCTION matrix_stinterpolation_1
-END INTERFACE
-
-INTERFACE STInterpolation
- 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..97d3e5b90
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Lagrange.F90
@@ -0,0 +1,201 @@
+! 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 :: LagrangeFacetElemShapeData
+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
+
+!----------------------------------------------------------------------------
+! LagrangeFacetElemShapeData@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-16
+! summary: This routine initiate the shape data
+
+INTERFACE LagrangeFacetElemShapeData
+ MODULE SUBROUTINE LagrangeFacetElemShapeData1( &
+ obj, facetElemsd, quad, facetQuad, localFaceNumber, nsd, xidim, &
+ elemType, refelemCoord, domainName, order, ipType, basisType, coeff, &
+ firstCall, alpha, beta, lambda)
+ CLASS(ElemshapeData_), INTENT(INOUT) :: obj
+ !! element shape data
+ CLASS(ElemshapeData_), INTENT(INOUT) :: facetElemsd
+ !! facet element shape data
+ TYPE(QuadraturePoint_), INTENT(IN) :: quad
+ !! quadrature point
+ TYPE(QuadraturePoint_), INTENT(IN) :: facetQuad
+ !! quadrature point on local facet
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ 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 LagrangeFacetElemShapeData1
+END INTERFACE LagrangeFacetElemShapeData
+
+END MODULE ElemshapeData_Lagrange
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90
new file mode 100644
index 000000000..e8b867966
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods.F90
@@ -0,0 +1,411 @@
+! 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
+!
+!
+! This file contains the interpolation methods interfaces\
+
+MODULE ElemshapeData_MatrixInterpolMethods
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: GetInterpolation
+PUBLIC :: GetInterpolation_
+PUBLIC :: Interpolation
+PUBLIC :: STInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This subroutine performs interpolation of matrix
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
+ !! interpolation of matrix
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ !! nodal value of matrix
+ END SUBROUTINE GetInterpolation1
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, &
+ dim1, dim2, dim3, scale, &
+ addContribution)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_1a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolation of matrix
+!
+!# Introduction
+!
+! This subroutine performs interpolation of matrix from its space-time
+! nodal values
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ !! space-time nodal value of matrix
+ END SUBROUTINE GetInterpolation2
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, &
+ dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, &
+ dim1, dim2, dim3, scale, &
+ addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_2a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolation of matrix
+!
+!# Introduction
+!
+! This subroutine performs interpolation of matrix from its space-time
+! nodal values
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :, :)
+ !! space-time interpolation
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ !! space-time nodal value of matrix
+ END SUBROUTINE GetInterpolation3
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolation of matrix
+!
+!# Introduction
+!
+! This subroutine performs interpolation of matrix from its space-time
+! nodal values
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, dim1, dim2, &
+ dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ !! space-time interpolation
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ !! space-time nodal value of matrix
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ !! size of data written in ans
+ END SUBROUTINE GetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolation of matrix
+!
+!# Introduction
+!
+! This subroutine performs interpolation of matrix from its space-time
+! nodal values
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, dim1, dim2, &
+ dim3, dim4, scale, &
+ addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ !! space-time interpolation
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ !! space-time nodal value of matrix
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ !! size of data written in ans
+ REAL(DFP), INTENT(IN) :: scale
+ !! scaling factor
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_3a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This subroutine performs interpolation of matrix FEVariable
+!
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
+ !! interpolation of matrix
+ TYPE(FEVariable_), INTENT(IN) :: val
+ !! matrix fe variable
+ END SUBROUTINE GetInterpolation4
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetInterpolation_4
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-04
+! summary: Get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, &
+ dim1, dim2, dim3, scale, &
+ addContribution, timeIndx)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ INTEGER(I4B), INTENT(IN), OPTIONAL :: timeIndx
+ END SUBROUTINE GetInterpolation_4a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4b(obj, ans, val, &
+ nrow, ncol, scale, &
+ addContribution, spaceIndx, &
+ timeIndx)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ INTEGER(I4B), INTENT(IN) :: timeIndx, spaceIndx
+ END SUBROUTINE GetInterpolation_4b
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
+ !! space-time interpolation of matrix
+ TYPE(FEVariable_), INTENT(IN) :: val
+ !! matrix fe variable
+ END SUBROUTINE GetInterpolation5
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, &
+ dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE GetInterpolation_5
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-04
+! summary: get interpolation of matrix without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, &
+ dim1, dim2, dim3, dim4, &
+ scale, addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_5a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! Interpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This function returns the interpolation of matrix
+
+INTERFACE
+ MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ REAL(DFP), ALLOCATABLE :: ans(:, :, :)
+ END FUNCTION Interpolation1
+END INTERFACE
+
+INTERFACE Interpolation
+ MODULE PROCEDURE Interpolation1
+END INTERFACE Interpolation
+
+!----------------------------------------------------------------------------
+! STInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: This function performs interpolations of matrix
+!
+!!# Introduction
+!
+! This function performs interpolation of a matrix from its space-time nodal
+! values.
+! $$u=u^{a}_{I}N^{I}T_{a}$$
+
+INTERFACE
+
+ MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ !! spatial nodal values of matrix
+ REAL(DFP), ALLOCATABLE :: ans(:, :, :)
+ !! Interpolation value of matrix
+ END FUNCTION STInterpolation1
+END INTERFACE
+
+INTERFACE STInterpolation
+ MODULE PROCEDURE STInterpolation1
+END INTERFACE STInterpolation
+
+END MODULE ElemshapeData_MatrixInterpolMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90 b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90
index 1df4c3ff0..9d1e6e6c0 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_Method.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_Method.F90
@@ -16,22 +16,34 @@
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
USE ElemshapeData_IOMethods
+
USE ElemshapeData_InterpolMethods
+USE ElemshapeData_ScalarInterpolMethods
+USE ElemshapeData_VectorInterpolMethods
+USE ElemshapeData_MatrixInterpolMethods
+
USE ElemshapeData_LocalDivergenceMethods
USE ElemshapeData_LocalGradientMethods
USE ElemshapeData_ProjectionMethods
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..4ea20281e 100644
--- a/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90
+++ b/src/modules/ElemshapeData/src/ElemshapeData_ProjectionMethods.F90
@@ -15,17 +15,20 @@
! along with this program. If not, see
!
-module ElemshapeData_ProjectionMethods
-USE BaseType
-USE GlobalData
+MODULE ElemshapeData_ProjectionMethods
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_, &
+ FEVariableVector_
+USE GlobalData, ONLY: I4B, DFP, LGT
IMPLICIT NONE
PRIVATE
-PUBLIC :: getProjectionOfdNdXt
-PUBLIC :: getProjectionOfdNTdXt
+PUBLIC :: GetProjectionOfdNdXt
+PUBLIC :: GetProjectionOfdNdXt_
+PUBLIC :: GetProjectionOfdNTdXt
+PUBLIC :: GetProjectionOfdNTdXt_
!----------------------------------------------------------------------------
-! getProjectionOfdNdXt@ProjectionMethods
+! GetProjectionOfdNdXt
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -41,21 +44,42 @@ module ElemshapeData_ProjectionMethods
! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$
INTERFACE
- MODULE PURE SUBROUTINE getProjectionOfdNdXt_1(obj, cdNdXt, val)
+ MODULE PURE SUBROUTINE GetProjectionOfdNdXt_1(obj, c, ans)
CLASS(ElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :)
- !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$
- REAL(DFP), INTENT(IN) :: val(:)
+ REAL(DFP), INTENT(IN) :: c(:)
!! constant value of vector
- END SUBROUTINE getProjectionOfdNdXt_1
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$
+ END SUBROUTINE GetProjectionOfdNdXt_1
END INTERFACE
-INTERFACE getProjectionOfdNdXt
- MODULE PROCEDURE getProjectionOfdNdXt_1
-END INTERFACE getProjectionOfdNdXt
+INTERFACE GetProjectionOfdNdXt
+ MODULE PROCEDURE GetProjectionOfdNdXt_1
+END INTERFACE GetProjectionOfdNdXt
!----------------------------------------------------------------------------
-! getProjectionOfdNdXt@getMethod
+! GetProjectionOfdNdXt_
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: get interpolation of vector without allocation
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNdXt1_(obj, c, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: c(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetProjectionOfdNdXt1_
+END INTERFACE
+
+INTERFACE GetProjectionOfdNdXt_
+ MODULE PROCEDURE GetProjectionOfdNdXt1_
+END INTERFACE GetProjectionOfdNdXt_
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNdXt
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -71,19 +95,40 @@ END SUBROUTINE getProjectionOfdNdXt_1
! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$
INTERFACE
- MODULE PURE SUBROUTINE getProjectionOfdNdXt_2(obj, cdNdXt, val)
+ MODULE PURE SUBROUTINE GetProjectionOfdNdXt_2(obj, c, crank, ans)
CLASS(ElemshapeData_), INTENT(IN) :: obj
!! ElemshapeData object
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :)
- !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$
- CLASS(FEVariable_), INTENT(IN) :: val
+ CLASS(FEVariable_), INTENT(IN) :: c
!! FEVariable vector
- END SUBROUTINE getProjectionOfdNdXt_2
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ !! rank of c should be vector
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ !! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$
+ END SUBROUTINE GetProjectionOfdNdXt_2
+END INTERFACE
+
+INTERFACE GetProjectionOfdNdXt
+ MODULE PROCEDURE GetProjectionOfdNdXt_2
+END INTERFACE GetProjectionOfdNdXt
+
+!----------------------------------------------------------------------------
+! GetProjectionofdNdXt_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNdXt2_(obj, c, crank, ans, nrow, &
+ ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ CLASS(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetProjectionOfdNdXt2_
END INTERFACE
-INTERFACE getProjectionOfdNdXt
- MODULE PROCEDURE getProjectionOfdNdXt_2
-END INTERFACE getProjectionOfdNdXt
+INTERFACE GetProjectionOfdNdXt_
+ MODULE PROCEDURE GetProjectionOfdNdXt2_
+END INTERFACE GetProjectionOfdNdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNdXt@getMethod
@@ -102,19 +147,41 @@ END SUBROUTINE getProjectionOfdNdXt_2
! $$P^{I}=c_{i}\frac{\partial N^{I}}{\partial x_{i}} $$
INTERFACE
- MODULE PURE SUBROUTINE getProjectionOfdNdXt_3(obj, cdNdXt, val)
+ MODULE PURE SUBROUTINE GetProjectionOfdNdXt_3(obj, c, ans)
CLASS(ElemshapeData_), INTENT(IN) :: obj
!! ElemshapeData object
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNdXt(:, :)
+ REAL(DFP), INTENT(IN) :: c(:, :)
+ !! a vector, defined over quadrature points
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
!! returned $c_{i}\frac{\partial N^{I}}{\partial x_{i}}$
- REAL(DFP), INTENT(IN) :: val(:, :)
+ END SUBROUTINE GetProjectionOfdNdXt_3
+END INTERFACE
+
+INTERFACE GetProjectionOfdNdXt
+ MODULE PROCEDURE GetProjectionOfdNdXt_3
+END INTERFACE GetProjectionOfdNdXt
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: get interpolation of vector without allocation
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNdXt3_(obj, c, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: c(:, :)
!! a vector, defined over quadrature points
- END SUBROUTINE getProjectionOfdNdXt_3
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetProjectionOfdNdXt3_
END INTERFACE
-INTERFACE getProjectionOfdNdXt
- MODULE PROCEDURE getProjectionOfdNdXt_3
-END INTERFACE getProjectionOfdNdXt
+INTERFACE GetProjectionOfdNdXt_
+ MODULE PROCEDURE GetProjectionOfdNdXt3_
+END INTERFACE GetProjectionOfdNdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNTdXt@getMethod
@@ -131,18 +198,48 @@ END SUBROUTINE getProjectionOfdNdXt_3
! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
INTERFACE
- MODULE PURE SUBROUTINE getProjectionOfdNTdXt_1(obj, cdNTdXt, val)
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_1(obj, c, ans)
CLASS(STElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :)
+ REAL(DFP), INTENT(IN) :: c(:)
+ !! constant value of vector
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
!! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$
- REAL(DFP), INTENT(IN) :: val(:)
+ END SUBROUTINE GetProjectionOfdNTdXt_1
+END INTERFACE
+
+INTERFACE GetProjectionOfdNTdXt
+ MODULE PROCEDURE GetProjectionOfdNdXt_1
+END INTERFACE GetProjectionOfdNTdXt
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-23
+! update: 2021-11-23
+! summary: Computes the projection of dNTdXt on a vector
+!
+! This subroutine computes the projcetion cdNTdXt on the vector `val`
+! Here the vector `val` is constant in space and time
+!
+! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt1_(obj, c, ans, dim1, dim2, &
+ dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: c(:)
!! constant value of vector
- END SUBROUTINE getProjectionOfdNTdXt_1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetProjectionOfdNTdXt1_
END INTERFACE
-INTERFACE getProjectionOfdNTdXt
- MODULE PROCEDURE getProjectionOfdNTdXt_1
-END INTERFACE getProjectionOfdNTdXt
+INTERFACE GetProjectionOfdNTdXt_
+ MODULE PROCEDURE GetProjectionOfdNTdXt1_
+END INTERFACE GetProjectionOfdNTdXt_
!----------------------------------------------------------------------------
! getProjectionOfdNTdXt@getMethod
@@ -163,23 +260,45 @@ END SUBROUTINE getProjectionOfdNTdXt_1
! - It can vary in space and time domain
!
! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
-!
+
INTERFACE
- MODULE PURE SUBROUTINE getProjectionOfdNTdXt_2(obj, cdNTdXt, val)
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_2(obj, c, crank, ans)
CLASS(STElemshapeData_), INTENT(IN) :: obj
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ !! constant value of vector
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
!! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$
- TYPE(FEVariable_), INTENT(IN) :: val
+ END SUBROUTINE GetProjectionOfdNTdXt_2
+END INTERFACE
+
+INTERFACE GetProjectionOfdNTdXt
+ MODULE PROCEDURE GetProjectionOfdNTdXt_2
+END INTERFACE GetProjectionOfdNTdXt
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt2_(obj, c, crank, ans, &
+ dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ TYPE(FEVariable_), INTENT(IN) :: c
!! constant value of vector
- END SUBROUTINE getProjectionOfdNTdXt_2
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! returned $c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetProjectionOfdNTdXt2_
END INTERFACE
-INTERFACE getProjectionOfdNTdXt
- MODULE PROCEDURE getProjectionOfdNTdXt_2
-END INTERFACE getProjectionOfdNTdXt
+INTERFACE GetProjectionOfdNTdXt_
+ MODULE PROCEDURE GetProjectionOfdNTdXt2_
+END INTERFACE GetProjectionOfdNTdXt_
!----------------------------------------------------------------------------
-! getProjectionOfdNTdXt@getMethod
+! GetProjectionOfdNTdXt@getMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -198,17 +317,57 @@ END SUBROUTINE getProjectionOfdNTdXt_2
! - It can vary in space and time domain
!
! $$P^{I,a}=c_{i}\frac{\partial N^{I} T_a}{\partial x_{i}}$$
-!
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt_3(obj, c, crank, ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
+ END SUBROUTINE GetProjectionOfdNTdXt_3
+END INTERFACE
+
+INTERFACE GetProjectionOfdNTdXt
+ MODULE PROCEDURE GetProjectionOfdNTdXt_3
+END INTERFACE GetProjectionOfdNTdXt
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt3_(obj, c, crank, ans, &
+ dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE GetProjectionOfdNTdXt3_
+END INTERFACE
+
+INTERFACE GetProjectionOfdNTdXt_
+ MODULE PROCEDURE GetProjectionOfdNTdXt3_
+END INTERFACE GetProjectionOfdNTdXt_
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
INTERFACE
- MODULE PURE SUBROUTINE getProjectionOfdNTdXt_3(obj, cdNTdXt, val)
+ MODULE PURE SUBROUTINE GetProjectionOfdNTdXt4_( &
+ obj, c, crank, ans, nrow, ncol, ips, ipt)
CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: cdNTdXt(:, :, :, :)
- TYPE(FEVariable_), INTENT(IN) :: val
- END SUBROUTINE getProjectionOfdNTdXt_3
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ INTEGER(I4B), INTENT(IN) :: ips, ipt
+ END SUBROUTINE GetProjectionOfdNTdXt4_
END INTERFACE
-INTERFACE getProjectionOfdNTdXt
- MODULE PROCEDURE getProjectionOfdNTdXt_3
-END INTERFACE getProjectionOfdNTdXt
+INTERFACE GetProjectionOfdNTdXt_
+ MODULE PROCEDURE GetProjectionOfdNTdXt4_
+END INTERFACE GetProjectionOfdNTdXt_
-end module ElemshapeData_ProjectionMethods
+END MODULE ElemshapeData_ProjectionMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90
new file mode 100644
index 000000000..4c967af73
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods.F90
@@ -0,0 +1,449 @@
+! 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
+!
+!
+! This file contains the interpolation methods interfaces\
+
+MODULE ElemshapeData_ScalarInterpolMethods
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: GetInterpolation
+PUBLIC :: GetInterpolation_
+PUBLIC :: Interpolation
+PUBLIC :: STInterpolation
+
+!----------------------------------------------------------------------------
+! getInterpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This subroutine performs interpolations of scalar
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a scalar from its spatial nodal
+! values.
+!
+! $$u=u_{I}N^{I}$$
+!
+! - TODO Make it work when the size of val is not the same as NNS
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val)
+ CLASS(ElemShapeData_), INTENT(IN) :: obj
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:)
+ !! Interpolation value of of scalar
+ REAL(DFP), INTENT(IN) :: val(:)
+ !! spatial nodal values of scalar
+ END SUBROUTINE GetInterpolation1
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, tsize)
+ CLASS(ElemShapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE GetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, &
+ tsize, scale, &
+ addContribution)
+ CLASS(ElemShapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_1a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! getInterpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolations of scalar nodal values
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a scalar from its space-time nodal
+! values.
+!
+! $$u=u^{a}_{I}N^{I}T_{a}$$
+!
+! The resultant represents the interpolation value of `val` at
+! spatial-quadrature points
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val)
+ CLASS(STElemShapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:)
+ !! Interpolation of scalar
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ !! space-time nodal values of scalar
+ !! val(I,a) where I is the node number and a is the time level
+ END SUBROUTINE GetInterpolation2
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of space-time nodal values at a single time
+!
+!# Introduction
+!
+! This method is like GetInterpolation_2 but without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, tsize)
+ CLASS(STElemShapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE GetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of space-time nodal values at a single time
+!
+!# Introduction
+!
+! This method is like GetInterpolation_2 but without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, &
+ tsize, scale, &
+ addContribution)
+ CLASS(STElemShapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_2a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolations of scalar nodal values
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a scalar from its space-time nodal
+! values.
+!
+! $$u=u^{a}_{I}N^{I}T_{a}$$
+!
+! The resultant represents the interpolation value of `val` at
+! spatial-temporal quadrature points
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :)
+ !! space-time Interpolation of scalar
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ !! space-time nodal values of scalar
+ END SUBROUTINE GetInterpolation3
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: Get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, &
+ nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, &
+ nrow, ncol, scale, &
+ addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_3a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! getInterpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: returns the interpolation of scalar FEVariable
+!
+!# Introduction
+!
+! Returns the interpolation of scalar variable
+! The scalar variable can be+
+!
+! - constant
+! - spatial nodal values
+! - spatial quadrature values
+! - space-time nodal values
+!
+!@note
+!This routine calls [[Interpolation]] function from the same module.
+!@endnote
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:)
+ !! interpolation of scalar
+ TYPE(FEVariable_), INTENT(IN) :: val
+ !! Scalar FE variable
+ END SUBROUTINE GetInterpolation4
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE GetInterpolation_4
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, tsize, &
+ scale, addContribution, timeIndx)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: timeIndx
+ END SUBROUTINE GetInterpolation_4a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-03
+! summary: Get Interpolation of scalar variable at a single space
+! and time integration point
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4b(obj, ans, val, scale, &
+ addContribution, timeIndx, &
+ spaceIndx)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans
+ TYPE(FEVariable_), INTENT(IN) :: val
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ INTEGER(I4B), INTENT(IN) :: spaceIndx
+ END SUBROUTINE GetInterpolation_4b
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! getInterpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolations of scalar FEVariable
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a scalar [[FEVariable_]]
+! The FE Variable can be a
+!
+! - constant
+! - spatial nodal values
+! - spatial quadrature values
+! - space-time nodal values
+!
+! $$u=u^{a}_{I}N^{I}T_{a}$$
+!
+! The resultant represents the interpolation value of `val` at
+! spatial-quadrature points
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ !! space-time interpolation of scalar
+ TYPE(FEVariable_), INTENT(IN) :: val
+ !! scalar FE variable
+ END SUBROUTINE GetInterpolation5
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, &
+ nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetInterpolation_5
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, &
+ nrow, ncol, scale, &
+ addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_5a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! Interpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This function returns the interpolation of a scalar
+
+INTERFACE Interpolation
+ MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ END FUNCTION Interpolation1
+END INTERFACE Interpolation
+
+!----------------------------------------------------------------------------
+! STInterpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-23
+! update: 2021-11-23
+! summary: This function performs interpolations of scalar
+!
+!# Introduction
+!
+! This function performs interpolation of a scalar from its space-time nodal
+! values.
+!
+! $$u=u^{a}_{I}N^{I}T_{a}$$
+
+INTERFACE
+ MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ !! space-time nodal values of scalar
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ !! Interpolation value of `val` at integration points
+ END FUNCTION STInterpolation1
+END INTERFACE
+
+INTERFACE STInterpolation
+ MODULE PROCEDURE STInterpolation1
+END INTERFACE STInterpolation
+
+END MODULE ElemshapeData_ScalarInterpolMethods
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_SetMethods.F90
index 74069ca7f..40d6a8b0c 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
@@ -224,6 +242,9 @@ MODULE PURE SUBROUTINE stsd_SetJacobian(obj, val, dNdXi, T)
CLASS(STElemshapeData_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: val(:, :, :)
!! Space time nodal values of coordinates
+ !! dim1 = spatial coordinates
+ !! dim2 = space nodes
+ !! dim3 = time nodes
REAL(DFP), INTENT(IN) :: dNdXi(:, :, :)
!! Local derivative of shape function for geometry
REAL(DFP), INTENT(IN) :: T(:)
@@ -256,6 +277,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 +334,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
@@ -364,12 +388,17 @@ END SUBROUTINE elemsd_Set1
!@endnote
INTERFACE Set
- MODULE PURE SUBROUTINE elemsd_Set2(facetobj, cellobj, cellval, cellN, &
- & celldNdXi, facetN, facetdNdXi)
+ MODULE PURE SUBROUTINE elemsd_Set2( &
+ facetobj, cellobj, cellval, facetval, cellN, celldNdXi, facetN, &
+ facetdNdXi)
CLASS(ElemshapeData_), INTENT(INOUT) :: facetobj
+ !! facet element shape data
CLASS(ElemshapeData_), INTENT(INOUT) :: cellobj
+ !! cell element shape data
REAL(DFP), INTENT(IN) :: cellval(:, :)
!! Spatial nodal coordinates of cell
+ REAL(DFP), INTENT(IN) :: facetval(:, :)
+ !! Spatial nodal coordinates of facet element
REAL(DFP), INTENT(IN) :: cellN(:, :)
!! shape function for cell
REAL(DFP), INTENT(IN) :: facetN(:, :)
@@ -394,20 +423,10 @@ END SUBROUTINE elemsd_Set2
INTERFACE Set
MODULE PURE SUBROUTINE elemsd_Set3( &
- & masterFacetobj, &
- & masterCellobj, &
- & masterCellval, &
- & masterCellN, &
- & masterCelldNdXi, &
- & masterFacetN, &
- & masterFacetdNdXi, &
- & slaveFacetobj, &
- & slaveCellobj, &
- & slaveCellval, &
- & slaveCellN, &
- & slaveCelldNdXi, &
- & slaveFacetN, &
- & slaveFacetdNdXi)
+ masterFacetobj, masterCellobj, masterCellval, masterCellN, &
+ masterCelldNdXi, masterFacetN, masterFacetdNdXi, masterFacetVal, &
+ slaveFacetobj, slaveCellobj, slaveCellval, slaveCellN, slaveCelldNdXi, &
+ slaveFacetN, slaveFacetdNdXi, slaveFacetVal)
CLASS(ElemshapeData_), INTENT(INOUT) :: masterFacetobj
CLASS(ElemshapeData_), INTENT(INOUT) :: masterCellobj
REAL(DFP), INTENT(IN) :: masterCellval(:, :)
@@ -421,6 +440,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( &
REAL(DFP), INTENT(IN) :: masterFacetdNdXi(:, :, :)
!! Local gradient of shape functions for geometry of
!! facet element of master cell
+ REAL(DFP), INTENT(IN) :: masterFacetVal(:, :)
+ !! master facet xij
CLASS(ElemshapeData_), INTENT(INOUT) :: slaveFacetobj
!! Shape function data for facet element of slave cell
CLASS(ElemshapeData_), INTENT(INOUT) :: slaveCellobj
@@ -437,6 +458,8 @@ MODULE PURE SUBROUTINE elemsd_Set3( &
REAL(DFP), INTENT(IN) :: slaveFacetdNdXi(:, :, :)
!! Local derivative of shape function for geometry of facet element
!! of slave
+ REAL(DFP), INTENT(IN) :: slaveFacetVal(:, :)
+ !! slave facet xij
END SUBROUTINE elemsd_Set3
END INTERFACE Set
diff --git a/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90 b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90
new file mode 100644
index 000000000..625b58020
--- /dev/null
+++ b/src/modules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods.F90
@@ -0,0 +1,420 @@
+! 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
+!
+!
+! This file contains the interpolation methods interfaces\
+
+MODULE ElemshapeData_VectorInterpolMethods
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: GetInterpolation
+PUBLIC :: GetInterpolation_
+PUBLIC :: Interpolation
+PUBLIC :: STInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This subroutine performs interpolation of a vector
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a vector from its spatial
+! nodal values
+!
+! $$u_{i}=u_{iI}N^{I}$$
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation1(obj, ans, val)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ !! interpolation of vector
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ !! nodal values of vector in `xiJ` format
+ END SUBROUTINE GetInterpolation1
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_1(obj, ans, val, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_1a(obj, ans, val, nrow, ncol, &
+ scale, addContribution)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_1a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolation of a vector
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a vector from its space-time
+! nodal values
+!
+! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation2(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :)
+ !!
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ !! space-time nodal values of vector in `xiJa` format
+ END SUBROUTINE GetInterpolation2
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_2(obj, ans, val, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_2a(obj, ans, val, nrow, ncol, &
+ scale, addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_2a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 1 Nov 2021
+! summary: This subroutine performs interpolation of a vector
+!
+!# Introduction
+!
+! This subroutine performs interpolation of a vector from its space-time
+! nodal values
+!
+! $$u_{i}=u^{a}_{iI}N^{I}T_{a}$$
+
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation3(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: ans(:, :, :)
+ !!
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ !! space-time nodal values of vector in `xiJa` format
+ END SUBROUTINE GetInterpolation3
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_3(obj, ans, val, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_3a(obj, ans, val, dim1, dim2, &
+ dim3, scale, addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_3a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: returns the interpolation of vector FEVariable
+!
+!# Introduction
+!
+! Returns the interpolation of vector variable
+! The vector variable can be+
+!
+! - constant
+! - spatial nodal values
+! - spatial quadrature values
+! - space-time nodal values
+!
+! NOTE This routine calls [[Interpolation]] function from the same module.
+!
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation4(obj, ans, val)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+ !! interpolation of vector
+ TYPE(FEVariable_), INTENT(IN) :: val
+ !! vector FEvariable
+ END SUBROUTINE GetInterpolation4
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4(obj, ans, val, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE GetInterpolation_4
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4a(obj, ans, val, nrow, ncol, &
+ scale, addContribution, timeIndx)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: timeIndx
+ END SUBROUTINE GetInterpolation_4a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_4b(obj, ans, val, tsize, &
+ scale, addContribution, &
+ timeIndx, spaceIndx)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ END SUBROUTINE GetInterpolation_4b
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: returns the interpolation of vector FEVariable
+!
+!# Introduction
+!
+! Returns the interpolation of vector variable
+! The vector variable can be+
+!
+! - constant
+! - spatial nodal values
+! - spatial quadrature values
+! - space-time nodal values
+!
+! NOTE This routine calls [[Interpolation]] function from the same module.
+!
+INTERFACE GetInterpolation
+ MODULE PURE SUBROUTINE GetInterpolation5(obj, ans, val)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
+ !! space-time interpolation of vector
+ TYPE(FEVariable_), INTENT(IN) :: val
+ !! vector FEvariable
+ END SUBROUTINE GetInterpolation5
+END INTERFACE GetInterpolation
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_5(obj, ans, val, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE GetInterpolation_5
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-30
+! summary: get interpolation of vector without allocation
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE GetInterpolation_5a(obj, ans, val, dim1, dim2, &
+ dim3, scale, addContribution)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ TYPE(FEVariable_), INTENT(IN) :: val
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE GetInterpolation_5a
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! Interpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 March 2021
+! summary: This function returns the interpolation of vector
+
+INTERFACE
+ MODULE PURE FUNCTION Interpolation1(obj, val) RESULT(ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ END FUNCTION Interpolation1
+END INTERFACE
+
+INTERFACE Interpolation
+ MODULE PROCEDURE Interpolation1
+END INTERFACE Interpolation
+
+!----------------------------------------------------------------------------
+! STInterpolation@InterpolMethods
+!----------------------------------------------------------------------------
+
+INTERFACE
+!! This function performs interpolations of vector
+
+!> author: Dr. Vikas Sharma
+!
+! This function performs interpolation of a vector from its space-time nodal
+! values.
+! $$u=u^{a}_{I}N^{I}T_{a}$$
+
+ MODULE PURE FUNCTION STInterpolation1(obj, val) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ !! spatial nodal values of vector
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! Interpolation value of vector
+ END FUNCTION STInterpolation1
+END INTERFACE
+
+INTERFACE STInterpolation
+ MODULE PROCEDURE STInterpolation1
+END INTERFACE STInterpolation
+
+END MODULE ElemshapeData_VectorInterpolMethods
diff --git a/src/modules/FACE/src/face.F90 b/src/modules/FACE/src/face.F90
index 385355136..0ce5c35fb 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/CMakeLists.txt b/src/modules/FEVariable/CMakeLists.txt
index 2bf970d1a..2e1b0aede 100644
--- a/src/modules/FEVariable/CMakeLists.txt
+++ b/src/modules/FEVariable/CMakeLists.txt
@@ -1,13 +1,39 @@
-# This file is a part of easifem-base
-# (c) 2021, Vikas Sharma, Ph.D.
-# All right reserved
+# 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
#
-# log
-# 16/02/2021 this file was created
-#-----------------------------------------------------------------------
-SET(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
-TARGET_SOURCES(
- ${PROJECT_NAME} PRIVATE
- ${src_path}/FEVariable_Method.F90
-)
\ No newline at end of file
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/FEVariable_Method.F90
+ ${src_path}/FEVariable_AdditionMethod.F90
+ ${src_path}/FEVariable_SubtractionMethod.F90
+ ${src_path}/FEVariable_DivisionMethod.F90
+ ${src_path}/FEVariable_MultiplicationMethod.F90
+ ${src_path}/FEVariable_DotProductMethod.F90
+ ${src_path}/FEVariable_ConstructorMethod.F90
+ ${src_path}/FEVariable_QuadratureVariableMethod.F90
+ ${src_path}/FEVariable_NodalVariableMethod.F90
+ ${src_path}/FEVariable_UnaryMethod.F90
+ ${src_path}/FEVariable_GetMethod.F90
+ ${src_path}/FEVariable_InterpolationMethod.F90
+ ${src_path}/FEVariable_ScalarInterpolationMethod.F90
+ ${src_path}/FEVariable_VectorInterpolationMethod.F90
+ ${src_path}/FEVariable_MatrixInterpolationMethod.F90
+ ${src_path}/FEVariable_IOMethod.F90
+ ${src_path}/FEVariable_MeanMethod.F90
+ ${src_path}/FEVariable_SetMethod.F90)
diff --git a/src/modules/FEVariable/src/FEVariable_AdditionMethod.F90 b/src/modules/FEVariable/src/FEVariable_AdditionMethod.F90
new file mode 100644
index 000000000..10add7673
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_AdditionMethod.F90
@@ -0,0 +1,87 @@
+! 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 FEVariable_AdditionMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: OPERATOR(+)
+
+!----------------------------------------------------------------------------
+! Addition@AdditioMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable + FEVariable
+
+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 OPERATOR(+)
+
+!----------------------------------------------------------------------------
+! Addition@AdditioMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable + Real
+
+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 OPERATOR(+)
+
+!----------------------------------------------------------------------------
+! Addition@AdditioMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = Real + FEVariable
+
+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 OPERATOR(+)
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_AdditionMethod
diff --git a/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90 b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90
new file mode 100644
index 000000000..cdd07b9e6
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_ConstructorMethod.F90
@@ -0,0 +1,117 @@
+! 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 FEVariable_ConstructorMethod
+USE BaseType, ONLY: FEVariable_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: DEALLOCATE
+PUBLIC :: ASSIGNMENT(=)
+PUBLIC :: Copy
+PUBLIC :: Initiate
+
+!----------------------------------------------------------------------------
+! Initiate@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-02
+! summary: Initiate FEVariable
+
+INTERFACE Initiate
+ MODULE PURE SUBROUTINE obj_Initiate1(obj, s, defineon, vartype, rank, &
+ len, val)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: s(:)
+ !! shape of data
+ INTEGER(I4B), INTENT(IN) :: defineon
+ !! where is the data defined nodal or quadrature
+ INTEGER(I4B), INTENT(IN) :: vartype
+ !! variable type
+ INTEGER(I4B), INTENT(IN) :: rank
+ !! rank of the variable
+ INTEGER(I4B), INTENT(IN) :: len
+ !! length of data to be extractd from val
+ REAL(DFP), INTENT(IN) :: val(:)
+ !! The size of val should be atleast len
+ END SUBROUTINE obj_Initiate1
+END INTERFACE Initiate
+
+!----------------------------------------------------------------------------
+! Initiate@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-02
+! summary: Initiate FEVariable
+
+INTERFACE Initiate
+ MODULE PURE SUBROUTINE obj_Initiate2(obj, s, defineon, vartype, rank, &
+ len)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: s(:)
+ !! shape of data
+ INTEGER(I4B), INTENT(IN) :: defineon
+ !! where is the data defined nodal or quadrature
+ INTEGER(I4B), INTENT(IN) :: vartype
+ !! variable type
+ INTEGER(I4B), INTENT(IN) :: rank
+ !! rank of the variable
+ INTEGER(I4B), INTENT(IN) :: len
+ !! length of data to be extractd from val
+ END SUBROUTINE obj_Initiate2
+END INTERFACE Initiate
+
+!----------------------------------------------------------------------------
+! Deallocate@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! summary: Deallocates the content of FEVariable
+
+INTERFACE DEALLOCATE
+ MODULE PURE SUBROUTINE obj_Deallocate(obj)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ END SUBROUTINE obj_Deallocate
+END INTERFACE DEALLOCATE
+
+!----------------------------------------------------------------------------
+! 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
+
+INTERFACE Copy
+ MODULE PROCEDURE obj_Copy
+END INTERFACE Copy
+
+END MODULE FEVariable_ConstructorMethod
diff --git a/src/modules/FEVariable/src/FEVariable_DivisionMethod.F90 b/src/modules/FEVariable/src/FEVariable_DivisionMethod.F90
new file mode 100644
index 000000000..3d342f346
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_DivisionMethod.F90
@@ -0,0 +1,87 @@
+! 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 FEVariable_DivisionMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: OPERATOR(/)
+
+!----------------------------------------------------------------------------
+! Division@DivisionMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = obj1 / obj2
+
+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 OPERATOR(/)
+
+!----------------------------------------------------------------------------
+! Division@DivisionMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = obj1 / val
+
+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 OPERATOR(/)
+
+!----------------------------------------------------------------------------
+! Division@DivisionMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = val / obj1
+
+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 OPERATOR(/)
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_DivisionMethod
diff --git a/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90 b/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90
new file mode 100644
index 000000000..6964ed6b4
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_DotProductMethod.F90
@@ -0,0 +1,57 @@
+! 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 FEVariable_DotProductMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: DOT_PRODUCT
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! update: 2021-12-12
+! summary: FEVariable = FEVariable + FEVariable
+
+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 DOT_PRODUCT
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_DotProductMethod
diff --git a/src/modules/FEVariable/src/FEVariable_GetMethod.F90 b/src/modules/FEVariable/src/FEVariable_GetMethod.F90
new file mode 100644
index 000000000..fa7578bcd
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_GetMethod.F90
@@ -0,0 +1,744 @@
+! 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 FEVariable_GetMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: SIZE
+PUBLIC :: SHAPE
+PUBLIC :: GetShape
+PUBLIC :: OPERATOR(.rank.)
+PUBLIC :: GetRank
+PUBLIC :: OPERATOR(.vartype.)
+PUBLIC :: GetVarType
+PUBLIC :: OPERATOR(.defineon.)
+PUBLIC :: GetDefineOn
+PUBLIC :: OPERATOR(.len.)
+PUBLIC :: GetLen
+PUBLIC :: isNodalVariable
+PUBLIC :: isQuadratureVariable
+PUBLIC :: FEVariable_ToChar
+PUBLIC :: FEVariable_ToInteger
+PUBLIC :: GetLambdaFromYoungsModulus
+PUBLIC :: GetTotalShape
+
+PUBLIC :: Get
+PUBLIC :: Get_
+
+!----------------------------------------------------------------------------
+! GetLambdaFromYoungsModulus@SpecialMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-12-12
+! summary: Get lame parameter lambda from YoungsModulus
+
+INTERFACE GetLambdaFromYoungsModulus
+ MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus( &
+ youngsModulus, shearModulus, lambda)
+ TYPE(FEVariable_), INTENT(IN) :: youngsModulus, shearModulus
+ TYPE(FEVariable_), INTENT(INOUT) :: lambda
+ END SUBROUTINE fevar_GetLambdaFromYoungsModulus
+END INTERFACE GetLambdaFromYoungsModulus
+
+!----------------------------------------------------------------------------
+! FEVariable_ToChar@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-07-01
+! summary: Converts scalar, vector, matrix to string name
+
+INTERFACE
+ MODULE PURE FUNCTION FEVariable_ToChar(name, isUpper) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ CHARACTER(:), ALLOCATABLE :: ans
+ LOGICAL(LGT), INTENT(IN), OPTIONAL :: isUpper
+ END FUNCTION FEVariable_ToChar
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! FEVariable_ToInteger@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-07-01
+! summary: Converts scalar, vector, matrix to string name
+
+INTERFACE
+ MODULE PURE FUNCTION FEVariable_ToInteger(name) RESULT(ans)
+ CHARACTER(*), INTENT(IN) :: name
+ INTEGER(I4B) :: ans
+ END FUNCTION FEVariable_ToInteger
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! SIZE@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+ END FUNCTION fevar_Size
+END INTERFACE Size
+
+!----------------------------------------------------------------------------
+! SHAPE@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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 PURE FUNCTION fevar_Shape(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ INTEGER(I4B), ALLOCATABLE :: ans(:)
+ END FUNCTION fevar_Shape
+END INTERFACE Shape
+
+!----------------------------------------------------------------------------
+! GetShape@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-28
+! summary: Returns the shape of data
+
+INTERFACE GetShape
+ MODULE PURE SUBROUTINE fevar_GetShape(obj, ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE fevar_GetShape
+END INTERFACE GetShape
+
+!----------------------------------------------------------------------------
+! GetTotalShape@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-03
+! summary: Returns the total size of shape of data
+!
+!# Introduction
+!
+! ans depends on the rank and vartype
+!
+!| rank | vartype | ans |
+!| --- | --- | --- |
+!| Scalar | Constant | 1 |
+!| Scalar | Space, Time | 1 |
+!| Scalar | SpaceTime | 2 |
+!| Vector | Constant | 1 |
+!| Vector | Space, Time | 2 |
+!| Vector | SpaceTime | 3 |
+!| Matrix | Constant | 2 |
+!| Matrix | Space, Time | 3 |
+!| Matrix | SpaceTime | 4 |
+
+INTERFACE GetTotalShape
+ MODULE PURE FUNCTION fevar_GetTotalShape(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ INTEGER(I4B) :: ans
+ END FUNCTION fevar_GetTotalShape
+END INTERFACE GetTotalShape
+
+!----------------------------------------------------------------------------
+! rank@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-27
+! update: 2021-11-27
+! summary: Returns the rank of FEvariable
+
+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 OPERATOR(.RANK.)
+
+INTERFACE GetRank
+ MODULE PROCEDURE fevar_rank
+END INTERFACE GetRank
+
+!----------------------------------------------------------------------------
+! vartype@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-27
+! update: 2021-11-27
+! summary: Returns the vartype of FEvariable
+
+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 OPERATOR(.vartype.)
+
+INTERFACE GetVarType
+ MODULE PROCEDURE fevar_vartype
+END INTERFACE GetVarType
+
+!----------------------------------------------------------------------------
+! defineon@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-27
+! update: 2021-11-27
+! summary: Returns the defineon of FEvariable
+
+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 OPERATOR(.defineon.)
+
+INTERFACE GetDefineOn
+ MODULE PROCEDURE fevar_defineon
+END INTERFACE GetDefineOn
+
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-27
+! summary: Returns the defineon of FEvariable
+
+INTERFACE OPERATOR(.len.)
+ MODULE PURE FUNCTION fevar_len(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ INTEGER(I4B) :: ans
+ END FUNCTION fevar_len
+END INTERFACE OPERATOR(.len.)
+
+INTERFACE GetLen
+ MODULE PROCEDURE fevar_len
+END INTERFACE GetLen
+
+!----------------------------------------------------------------------------
+! IsNodalVariable@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-27
+! update: 2021-11-27
+! summary: Returns the defineon of FEvariable
+
+INTERFACE IsNodalVariable
+ MODULE PURE FUNCTION fevar_IsNodalVariable(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ LOGICAL(LGT) :: ans
+ END FUNCTION fevar_IsNodalVariable
+END INTERFACE IsNodalVariable
+
+!----------------------------------------------------------------------------
+! isQuadratureVariable@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-27
+! update: 2021-11-27
+! summary: Returns the defineon of FEvariable
+
+INTERFACE IsQuadratureVariable
+ MODULE PURE FUNCTION fevar_IsQuadratureVariable(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ LOGICAL(LGT) :: ans
+ END FUNCTION fevar_IsQuadratureVariable
+END INTERFACE IsQuadratureVariable
+
+!----------------------------------------------------------------------------
+! Get@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is scalar, constant
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get@GetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is scalar, space
+
+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 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is scalar, time
+
+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 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is scalar, SpaceTime
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is vector, constant
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is vector, space
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is vector, time
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is vector, spaceTime
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is Matrix, Constant
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is Matrix, Space
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is Matrix, Time
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2 Jan 2022
+! summary: Returns value which is Matrix, SpaceTime
+
+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 Get
+
+!----------------------------------------------------------------------------
+! Get_@GetMethods
+!----------------------------------------------------------------------------
+
+!> 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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_GetMethod
diff --git a/src/modules/FEVariable/src/FEVariable_IOMethod.F90 b/src/modules/FEVariable/src/FEVariable_IOMethod.F90
new file mode 100644
index 000000000..1c9bf063c
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_IOMethod.F90
@@ -0,0 +1,52 @@
+! 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 FEVariable_IOMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: Display
+
+!----------------------------------------------------------------------------
+! Display@IOMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Displays the content of [[FEVariable_]]
+
+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 Display
+
+END MODULE FEVariable_IOMethod
diff --git a/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90
new file mode 100644
index 000000000..1d06938b2
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_InterpolationMethod.F90
@@ -0,0 +1,91 @@
+! 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 FEVariable_InterpolationMethod
+USE BaseType, ONLY: FEVariable_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE FEVariableGetInterpolation_1( &
+ obj, N, nns, nips, scale, addContribution, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable_ format
+ !! Scalar, or Vector, or Matrix, Quadrature, Space
+ END SUBROUTINE FEVariableGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE FEVariableGetInterpolation_2( &
+ obj, N, nns, nips, T, nnt, scale, addContribution, timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! shape functions data, T(I) : I is node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of nodes in N, bound for dim1 in N
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable_ format
+ END SUBROUTINE FEVariableGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+END MODULE FEVariable_InterpolationMethod
diff --git a/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90
new file mode 100644
index 000000000..d8a1955a7
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_MatrixInterpolationMethod.F90
@@ -0,0 +1,414 @@
+! 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 FEVariable_MatrixInterpolationMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+PUBLIC :: GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, ans, dim1, &
+ dim2, dim3)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! Number of data written in ans
+ END SUBROUTINE MatrixConstantGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is for putting value in ans
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable
+ !! Matrix, Quadrature, Space
+ END SUBROUTINE MatrixConstantGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixConstantGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, &
+ ans, nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ END SUBROUTINE MatrixConstantGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixSpaceGetInterpolation_1(obj, rank, vartype, &
+ N, nns, nips, &
+ scale, &
+ addContribution, &
+ ans, dim1, dim2, dim3)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! Number of data written in ans
+ END SUBROUTINE MatrixSpaceGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixSpaceGetInterpolation_2(obj, rank, vartype, &
+ N, nns, nips, &
+ scale, &
+ addContribution, &
+ timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is for putting value in ans
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable
+ !! Size of ans should be at least nips
+ END SUBROUTINE MatrixSpaceGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixSpaceGetInterpolation_3(obj, rank, vartype, &
+ N, nns, spaceIndx, &
+ timeIndx, &
+ scale, &
+ addContribution, &
+ ans, nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ END SUBROUTINE MatrixSpaceGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_1(obj, rank, &
+ vartype, &
+ N, nns, nips, &
+ T, nnt, &
+ scale, &
+ addContribution, &
+ ans, dim1, dim2, &
+ dim3, timeIndx)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! Number of data written in ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is used when varType is spaceTime and defined on Quad
+ END SUBROUTINE MatrixSpaceTimeGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_2(obj, rank, &
+ vartype, &
+ N, nns, nips, &
+ T, nnt, &
+ scale, &
+ addContribution, &
+ timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is used when varType is spaceTime and defined on Quad
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable
+ END SUBROUTINE MatrixSpaceTimeGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixSpaceTimeGetInterpolation_3(obj, rank, &
+ vartype, &
+ N, nns, &
+ spaceIndx, &
+ timeIndx, &
+ T, nnt, &
+ scale, &
+ addContribution, &
+ ans, nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ END SUBROUTINE MatrixSpaceTimeGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@MatrixInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Matrix, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE MatrixGetInterpolation_3( &
+ obj, rank, N, nns, spaceIndx, timeIndx, T, nnt, scale, addContribution, &
+ ans, nrow, ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ END SUBROUTINE MatrixGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_MatrixInterpolationMethod
diff --git a/src/modules/FEVariable/src/FEVariable_MeanMethod.F90 b/src/modules/FEVariable/src/FEVariable_MeanMethod.F90
new file mode 100644
index 000000000..7162e187f
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_MeanMethod.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
+
+MODULE FEVariable_MeanMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: MEAN
+
+!----------------------------------------------------------------------------
+! MEAN@MeanMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 May 2022
+! summary: FEVariable = Mean( obj )
+
+INTERFACE MEAN
+ MODULE PURE FUNCTION fevar_Mean1(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariable_) :: ans
+ END FUNCTION fevar_Mean1
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! MEAN@MeanMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 May 2022
+! summary: FEVariable = Mean( obj )
+
+INTERFACE MEAN
+ MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: dataType
+ REAL(DFP) :: ans
+ END FUNCTION fevar_Mean2
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! MEAN@MeanMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 May 2022
+! summary: FEVariable = Mean( obj )
+
+INTERFACE MEAN
+ MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: dataType
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ END FUNCTION fevar_Mean3
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! MEAN@MeanMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 May 2022
+! summary: FEVariable = Mean( obj )
+
+INTERFACE MEAN
+ MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableMatrix_), INTENT(IN) :: dataType
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ END FUNCTION fevar_Mean4
+END INTERFACE
+
+END MODULE FEVariable_MeanMethod
diff --git a/src/modules/FEVariable/src/FEVariable_Method.F90 b/src/modules/FEVariable/src/FEVariable_Method.F90
index 887b43b2e..a6dbabc49 100644
--- a/src/modules/FEVariable/src/FEVariable_Method.F90
+++ b/src/modules/FEVariable/src/FEVariable_Method.F90
@@ -15,1486 +15,21 @@
! along with this program. If not, see
MODULE FEVariable_Method
-USE BaseType
-USE GlobalData
-IMPLICIT NONE
-PRIVATE
-
-PUBLIC :: Display
-PUBLIC :: QuadratureVariable
-PUBLIC :: DEALLOCATE
-PUBLIC :: NodalVariable
-PUBLIC :: SIZE
-PUBLIC :: SHAPE
-PUBLIC :: OPERATOR(.RANK.)
-PUBLIC :: OPERATOR(.vartype.)
-PUBLIC :: OPERATOR(.defineon.)
-PUBLIC :: isNodalVariable
-PUBLIC :: isQuadratureVariable
-PUBLIC :: Get
-PUBLIC :: OPERATOR(+)
-PUBLIC :: OPERATOR(-)
-PUBLIC :: OPERATOR(*)
-PUBLIC :: ABS
-PUBLIC :: DOT_PRODUCT
-PUBLIC :: OPERATOR(/)
-PUBLIC :: OPERATOR(**)
-PUBLIC :: SQRT
-PUBLIC :: NORM2
-PUBLIC :: OPERATOR(.EQ.)
-PUBLIC :: OPERATOR(.NE.)
-PUBLIC :: MEAN
-PUBLIC :: GetLambdaFromYoungsModulus
-
-!----------------------------------------------------------------------------
-! GetLambdaFromYoungsModulus@SpecialMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-12-12
-! summary: Get lame parameter lambda from YoungsModulus
-
-INTERFACE GetLambdaFromYoungsModulus
- MODULE PURE SUBROUTINE fevar_GetLambdaFromYoungsModulus(youngsModulus, &
- & shearModulus, lambda)
- TYPE(FEVariable_), INTENT(IN) :: youngsModulus, shearModulus
- TYPE(FEVariable_), INTENT(INOUT) :: lambda
- END SUBROUTINE fevar_GetLambdaFromYoungsModulus
-END INTERFACE GetLambdaFromYoungsModulus
-
-!----------------------------------------------------------------------------
-! Display@IOMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Displays the content of [[FEVariable_]]
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! QuadratureVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create quadrature variable, which is Scalar, Constant
-
-INTERFACE
- MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val
- 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
-
-!----------------------------------------------------------------------------
-! QuadratureVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create quadrature variable, which is Scalar, Space
-
-INTERFACE
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Scalar_Space
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_Space
-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, Time
-
-INTERFACE
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Scalar_Time
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_Time
-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
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Scalar_SpaceTime
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Scalar_SpaceTime
-END INTERFACE QuadratureVariable
-
-!----------------------------------------------------------------------------
-! NodalVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create quadrature variable, which is Vector, Constant
-
-INTERFACE
- MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:)
- 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
-
-!----------------------------------------------------------------------------
-! QuadratureVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create quadrature variable, which is Vector, Space
-
-INTERFACE
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Vector_Space
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_Space
-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
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Vector_Time
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_Time
-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
- MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- TYPE(FEVariableVector_), INTENT(IN) :: rank
- TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
- END FUNCTION Quadrature_Vector_SpaceTime
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Vector_SpaceTime
-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
- MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :)
- TYPE(FEVariableMatrix_), INTENT(IN) :: rank
- TYPE(FEVariableConstant_), INTENT(IN) :: vartype
- END FUNCTION Quadrature_Matrix_Constant
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_Constant
-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
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Matrix_Space
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_Space
-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
- MODULE PURE FUNCTION Quadrature_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 Quadrature_Matrix_Time
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_Time
-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
- MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :, :)
- TYPE(FEVariableMatrix_), INTENT(IN) :: rank
- TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
- END FUNCTION Quadrature_Matrix_SpaceTime
-END INTERFACE
-
-INTERFACE QuadratureVariable
- MODULE PROCEDURE Quadrature_Matrix_SpaceTime
-END INTERFACE QuadratureVariable
-
-!----------------------------------------------------------------------------
-! Deallocate@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Deallocates the content of FEVariable
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! NodalVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create nodal variable, which is scalar, constant
-
-INTERFACE
- MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val
- 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
-
-!----------------------------------------------------------------------------
-! NodalVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create nodal variable, which is scalar, Space
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! NodalVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create nodal variable, which is scalar, Time
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! NodalVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create nodal variable, which is scalar, SpaceTime
-
-INTERFACE
- 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
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Scalar_SpaceTime
-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, Constant
-
-INTERFACE
- MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:)
- 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
-
-!----------------------------------------------------------------------------
-! NodalVariable@ConstructorMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-10
-! update: 2021-12-10
-! summary: Create nodal variable, which is vector, Space
-
-INTERFACE
- 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
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_Space
-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
- 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
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_Time
-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
- MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :)
- TYPE(FEVariableVector_), INTENT(IN) :: rank
- TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
- END FUNCTION Nodal_Vector_SpaceTime
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Vector_SpaceTime
-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
- MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :)
- TYPE(FEVariableMatrix_), INTENT(IN) :: rank
- TYPE(FEVariableConstant_), INTENT(IN) :: vartype
- END FUNCTION Nodal_Matrix_Constant
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_Constant
-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
- 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
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_Space
-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
- 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
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_Time
-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
- MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) &
- & RESULT(obj)
- TYPE(FEVariable_) :: obj
- REAL(DFP), INTENT(IN) :: val(:, :, :, :)
- TYPE(FEVariableMatrix_), INTENT(IN) :: rank
- TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
- END FUNCTION Nodal_Matrix_SpaceTime
-END INTERFACE
-
-INTERFACE NodalVariable
- MODULE PROCEDURE Nodal_Matrix_SpaceTime
-END INTERFACE NodalVariable
-
-!----------------------------------------------------------------------------
-! SIZE@GetMethods
-!----------------------------------------------------------------------------
-
-INTERFACE
- MODULE PURE FUNCTION fevar_Size(obj, Dim) RESULT(Ans)
- CLASS(FEVariable_), INTENT(IN) :: obj
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: Dim
- INTEGER(I4B) :: Ans
- END FUNCTION fevar_Size
-END INTERFACE
-
-INTERFACE SIZE
- MODULE PROCEDURE fevar_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
-
-INTERFACE Shape
- MODULE PROCEDURE fevar_Shape
-END INTERFACE Shape
-
-!----------------------------------------------------------------------------
-! rank@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-11-27
-! update: 2021-11-27
-! summary: Returns the rank of FEvariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-11-27
-! update: 2021-11-27
-! summary: Returns the vartype of FEvariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-11-27
-! update: 2021-11-27
-! summary: Returns the defineon of FEvariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-11-27
-! update: 2021-11-27
-! summary: Returns the defineon of FEvariable
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! isQuadratureVariable@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-11-27
-! update: 2021-11-27
-! summary: Returns the defineon of FEvariable
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is scalar, constant
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is scalar, space
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is scalar, time
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is scalar, SpaceTime
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is vector, constant
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is vector, space
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is vector, time
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is vector, spaceTime
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is Matrix, Constant
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is Matrix, Space
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is Matrix, Time
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Get@GetMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2 Jan 2022
-! summary: Returns value which is Matrix, SpaceTime
-
-INTERFACE
- 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
-
-!----------------------------------------------------------------------------
-! Addition@AdditioMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable + FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable + Real
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = Real + FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable - FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable - RealVal
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = RealVal - FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-1
-! summary: FEVariable = FEVariable * FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable * Real
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = Real * FEVariable
-
-INTERFACE
- 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)
- CLASS(FEVariable_), INTENT(IN) :: obj
- TYPE(FEVariable_) :: ans
- END FUNCTION fevar_abs
-END INTERFACE
-
-INTERFACE ABS
- MODULE PROCEDURE fevar_abs
-END INTERFACE ABS
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable + FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable - FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable - Real
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = Real - FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable + FEVariable
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = FEVariable + FEVariable
-
-INTERFACE
- 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)
- CLASS(FEVariable_), INTENT(IN) :: obj
- TYPE(FEVariable_) :: ans
- END FUNCTION fevar_norm2
-END INTERFACE
-
-INTERFACE NORM2
- MODULE PROCEDURE fevar_norm2
-END INTERFACE NORM2
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = NORM2(FEVariable)
-
-INTERFACE
- 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.)
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2021-12-12
-! update: 2021-12-12
-! summary: FEVariable = NORM2(FEVariable)
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 May 2022
-! summary: FEVariable = Mean( obj )
-
-INTERFACE
- 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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 May 2022
-! summary: FEVariable = Mean( obj )
-
-INTERFACE
- MODULE PURE FUNCTION fevar_Mean2(obj, dataType) RESULT(ans)
- CLASS(FEVariable_), INTENT(IN) :: obj
- TYPE(FEVariableScalar_), INTENT(IN) :: dataType
- REAL(DFP) :: ans
- END FUNCTION fevar_Mean2
-END INTERFACE
-
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean2
-END INTERFACE MEAN
-
-!----------------------------------------------------------------------------
-! MEAN@MeanMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 May 2022
-! summary: FEVariable = Mean( obj )
-
-INTERFACE
- MODULE PURE FUNCTION fevar_Mean3(obj, dataType) RESULT(ans)
- CLASS(FEVariable_), INTENT(IN) :: obj
- TYPE(FEVariableVector_), INTENT(IN) :: dataType
- REAL(DFP), ALLOCATABLE :: ans(:)
- END FUNCTION fevar_Mean3
-END INTERFACE
-
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean3
-END INTERFACE MEAN
-
-!----------------------------------------------------------------------------
-! MEAN@MeanMethods
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 May 2022
-! summary: FEVariable = Mean( obj )
-
-INTERFACE
- MODULE PURE FUNCTION fevar_Mean4(obj, dataType) RESULT(ans)
- CLASS(FEVariable_), INTENT(IN) :: obj
- TYPE(FEVariableMatrix_), INTENT(IN) :: dataType
- REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION fevar_Mean4
-END INTERFACE
-
-INTERFACE MEAN
- MODULE PROCEDURE fevar_Mean4
-END INTERFACE MEAN
-
+USE FEVariable_AdditionMethod
+USE FEVariable_ConstructorMethod
+USE FEVariable_DivisionMethod
+USE FEVariable_DotProductMethod
+USE FEVariable_GetMethod
+USE FEVariable_IOMethod
+USE FEVariable_MeanMethod
+USE FEVariable_MultiplicationMethod
+USE FEVariable_NodalVariableMethod
+USE FEVariable_QuadratureVariableMethod
+USE FEVariable_SetMethod
+USE FEVariable_SubtractionMethod
+USE FEVariable_UnaryMethod
+USE FEVariable_ScalarInterpolationMethod
+USE FEVariable_VectorInterpolationMethod
+USE FEVariable_MatrixInterpolationMethod
+USE FEVariable_InterpolationMethod
END MODULE FEVariable_Method
diff --git a/src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90 b/src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90
new file mode 100644
index 000000000..cbfadabdb
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_MultiplicationMethod.F90
@@ -0,0 +1,91 @@
+! 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 FEVariable_MultiplicationMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: OPERATOR(*)
+
+!----------------------------------------------------------------------------
+! Multiplication@MultiplicationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! update: 2021-12-1
+! summary: FEVariable = FEVariable * FEVariable
+
+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 OPERATOR(*)
+
+!----------------------------------------------------------------------------
+! Multiplication@MultiplicationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! update: 2021-12-12
+! summary: FEVariable = FEVariable * Real
+
+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 OPERATOR(*)
+
+!----------------------------------------------------------------------------
+! Multiplication@MultiplicationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! update: 2021-12-12
+! summary: FEVariable = Real * FEVariable
+
+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 OPERATOR(*)
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_MultiplicationMethod
diff --git a/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90
new file mode 100644
index 000000000..e15511ea0
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_NodalVariableMethod.F90
@@ -0,0 +1,750 @@
+! 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 FEVariable_NodalVariableMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is scalar, constant
+
+INTERFACE
+ MODULE PURE FUNCTION Nodal_Scalar_Constant(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val
+ 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
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is scalar, Space
+
+INTERFACE
+ 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
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-11-04
+! summary: Create nodal variable, which is scalar, Space
+
+INTERFACE
+ MODULE PURE FUNCTION Nodal_Scalar_Space2(tsize, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: tsize
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Scalar_Space2
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Scalar_Space2
+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, Time
+
+INTERFACE
+ 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
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is scalar, Time
+
+INTERFACE
+ MODULE PURE FUNCTION Nodal_Scalar_Time2(tsize, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: tsize
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Scalar_Time2
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Scalar_Time2
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Scalar_SpaceTime
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Scalar_SpaceTime2
+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
+ MODULE PURE FUNCTION Nodal_Scalar_SpaceTime3(nrow, ncol, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: nrow, ncol
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Scalar_SpaceTime3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Scalar_SpaceTime3
+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, Constant
+
+INTERFACE
+ MODULE PURE FUNCTION Nodal_Vector_Constant(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ 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
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create nodal variable, which is vector, Constant
+
+INTERFACE
+ MODULE PURE FUNCTION Nodal_Vector_Constant2(tsize, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: tsize
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Vector_Constant2
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Constant2
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Space
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Space2
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-11-05
+! summary: Create nodal variable, which is vector, Space
+
+INTERFACE
+ MODULE PURE FUNCTION Nodal_Vector_Space3(nrow, ncol, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: nrow, ncol
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Vector_Space3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Space3
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Time
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Time2
+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
+ MODULE PURE FUNCTION Nodal_Vector_Time3(nrow, ncol, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: nrow, ncol
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Vector_Time3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_Time3
+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
+ MODULE PURE FUNCTION Nodal_Vector_SpaceTime(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Vector_SpaceTime
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_SpaceTime
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_SpaceTime2
+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
+ MODULE PURE FUNCTION Nodal_Vector_SpaceTime3(dim1, dim2, dim3, rank, &
+ vartype) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Vector_SpaceTime3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Vector_SpaceTime3
+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
+ MODULE PURE FUNCTION Nodal_Matrix_Constant(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Matrix_Constant
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Constant
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Constant2
+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
+ MODULE PURE FUNCTION Nodal_Matrix_Constant3(nrow, ncol, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: nrow, ncol
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Matrix_Constant3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Constant3
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Space
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Space2
+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
+ MODULE PURE FUNCTION Nodal_Matrix_Space3(dim1, dim2, dim3, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Matrix_Space3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Space3
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Time
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Time2
+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
+ MODULE PURE FUNCTION Nodal_Matrix_Time3(dim1, dim2, dim3, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Matrix_Time3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_Time3
+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
+ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Matrix_SpaceTime
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_SpaceTime
+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
+ 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
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_SpaceTime2
+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
+ MODULE PURE FUNCTION Nodal_Matrix_SpaceTime3(dim1, dim2, dim3, dim4, rank, &
+ vartype) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3, dim4
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Nodal_Matrix_SpaceTime3
+END INTERFACE
+
+INTERFACE NodalVariable
+ MODULE PROCEDURE Nodal_Matrix_SpaceTime3
+END INTERFACE NodalVariable
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_NodalVariableMethod
diff --git a/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90 b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90
new file mode 100644
index 000000000..fce35456d
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_QuadratureVariableMethod.F90
@@ -0,0 +1,616 @@
+! 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 FEVariable_QuadratureVariableMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Scalar, Constant
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_Scalar_Constant(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val
+ 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
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Scalar, Space
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Scalar_Space
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_Space
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-11-04
+! summary: Create quadrature variable, which is Scalar, Space
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_Scalar_Space2(tsize, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: tsize
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Scalar_Space2
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_Space2
+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, Time
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Scalar_Time
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_Time
+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, Time
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_Scalar_Time2(tsize, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: tsize
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Scalar_Time2
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_Time2
+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
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Scalar_SpaceTime
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_SpaceTime
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_SpaceTime2
+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
+ MODULE PURE FUNCTION Quadrature_Scalar_SpaceTime3( &
+ nrow, ncol, rank, vartype) RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: nrow, ncol
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Scalar_SpaceTime3
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Scalar_SpaceTime3
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! NodalVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Vector, Constant
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_Vector_Constant(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ 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
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-10
+! update: 2021-12-10
+! summary: Create quadrature variable, which is Vector, Space
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Vector_Space
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_Space
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_Space2
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-11-05
+! summary: Create quadrature variable, which is Vector, Space
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_Vector_Space3(nrow, ncol, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ INTEGER(I4B), INTENT(IN) :: nrow, ncol
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Vector_Space3
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_Space3
+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
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Vector_Time
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_Time
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_Time2
+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
+ MODULE PURE FUNCTION Quadrature_Vector_SpaceTime(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Vector_SpaceTime
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_SpaceTime
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_SpaceTime2
+END INTERFACE QuadratureVariable
+
+!----------------------------------------------------------------------------
+! QuadratureVariable@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-12-11
+! summary: Create FEVariable which is vector and space-time
+
+INTERFACE
+ MODULE PURE FUNCTION Quadrature_Vector_SpaceTime3(rank, vartype, &
+ dim1, dim2, dim3) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, dim3
+ END FUNCTION Quadrature_Vector_SpaceTime3
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Vector_SpaceTime3
+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
+ MODULE PURE FUNCTION Quadrature_Matrix_Constant(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Matrix_Constant
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_Constant
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_Constant2
+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
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Matrix_Space
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_Space
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_Space2
+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
+ MODULE PURE FUNCTION Quadrature_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 Quadrature_Matrix_Time
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_Time
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_Time2
+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
+ MODULE PURE FUNCTION Quadrature_Matrix_SpaceTime(val, rank, vartype) &
+ RESULT(obj)
+ TYPE(FEVariable_) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ END FUNCTION Quadrature_Matrix_SpaceTime
+END INTERFACE
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_SpaceTime
+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
+ 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
+
+INTERFACE QuadratureVariable
+ MODULE PROCEDURE Quadrature_Matrix_SpaceTime2
+END INTERFACE QuadratureVariable
+
+END MODULE FEVariable_QuadratureVariableMethod
diff --git a/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90
new file mode 100644
index 000000000..a77d18f36
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_ScalarInterpolationMethod.F90
@@ -0,0 +1,396 @@
+! 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 FEVariable_ScalarInterpolationMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ END SUBROUTINE ScalarConstantGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index for ans
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable_ format
+ !! Scalar, QuadratureVariable, Space
+ END SUBROUTINE ScalarConstantGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarConstantGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, &
+ ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx
+ !! number of integration points in N, bound for dim2 in N
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ END SUBROUTINE ScalarConstantGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ END SUBROUTINE ScalarSpaceGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable_ format
+ !! Scalar, QuadratureVariable, Space
+ END SUBROUTINE ScalarSpaceGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarSpaceGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, &
+ ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! space and time integration point index
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ END SUBROUTINE ScalarSpaceGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, &
+ ans, tsize, timeIndx)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is used when varType is spaceTime and defined on Quad
+ END SUBROUTINE ScalarSpaceTimeGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space-time
+!
+!# Introduction
+!
+! If obj%varType is SpaceTime Then following thing happens
+! In this case ans will be Scalar, Space, QuadratureVariable
+! The values corresponding to timeIndx will be returned in ans as follows
+!
+! valStart = (timeIndx - 1) * obj%s(1)
+! DO aa = 1, tsize
+! ans%val(aa) = ans%val(aa) + scale * obj%val(aa+valStart)
+! END DO
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, &
+ timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is used when varType is spaceTime and defined on Quad
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable_ format
+ !! Scalar, QuadratureVariable, SpaceTime
+ END SUBROUTINE ScalarSpaceTimeGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarSpaceTimeGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, T, nnt, scale, &
+ addContribution, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ END SUBROUTINE ScalarSpaceTimeGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@ScalarInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of scalar, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE ScalarGetInterpolation_3( &
+ obj, rank, N, nns, spaceIndx, timeIndx, T, nnt, scale, addContribution, &
+ ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ END SUBROUTINE ScalarGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_ScalarInterpolationMethod
diff --git a/src/modules/FEVariable/src/FEVariable_SetMethod.F90 b/src/modules/FEVariable/src/FEVariable_SetMethod.F90
new file mode 100644
index 000000000..099efef6f
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_SetMethod.F90
@@ -0,0 +1,230 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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 FEVariable_SetMethod
+USE BaseType, ONLY: FEVariable_, &
+ TypeFEVariableOpt, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set1(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set1
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set2(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set2
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set3(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set3
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set4(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set4
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set5(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set5
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set6(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set6
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set7(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set7
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set8(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set8
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set9(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set9
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set10(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:)
+ TYPE(FEVariableScalar_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set10
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set11(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :)
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set11
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set12(obj, val, rank, vartype, scale, &
+ addContribution)
+ TYPE(FEVariable_), INTENT(INOUT) :: obj
+ REAL(DFP), INTENT(IN) :: val(:, :, :)
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rank
+ TYPE(FEVariableTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: scale
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ END SUBROUTINE obj_Set12
+END INTERFACE Set
+
+END MODULE FEVariable_SetMethod
diff --git a/src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90 b/src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90
new file mode 100644
index 000000000..bc6e69697
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_SubtractionMethod.F90
@@ -0,0 +1,87 @@
+! 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 FEVariable_SubtractionMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+PUBLIC :: OPERATOR(-)
+
+!----------------------------------------------------------------------------
+! Substraction@SubstractioMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable - FEVariable
+
+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 OPERATOR(-)
+
+!----------------------------------------------------------------------------
+! Substraction@SubstractioMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable - RealVal
+
+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 OPERATOR(-)
+
+!----------------------------------------------------------------------------
+! Substraction@SubstractioMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = RealVal - FEVariable
+
+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 OPERATOR(-)
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_SubtractionMethod
diff --git a/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90 b/src/modules/FEVariable/src/FEVariable_UnaryMethod.F90
new file mode 100644
index 000000000..ef59f1d6e
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_UnaryMethod.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 FEVariable_UnaryMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableScalar_, &
+ FEVariableVector_, &
+ FEVariableMatrix_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: ABS
+PUBLIC :: OPERATOR(**)
+PUBLIC :: Sqrt
+PUBLIC :: OPERATOR(.EQ.)
+PUBLIC :: OPERATOR(.NE.)
+PUBLIC :: Norm2
+
+!----------------------------------------------------------------------------
+! Abs@AbsMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable + FEVariable
+
+INTERFACE ABS
+ MODULE PURE FUNCTION fevar_abs(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariable_) :: ans
+ END FUNCTION fevar_abs
+END INTERFACE ABS
+
+!----------------------------------------------------------------------------
+! Power@PowerMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable + FEVariable
+
+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 OPERATOR(**)
+
+!----------------------------------------------------------------------------
+! Sqrt@UnaryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = FEVariable + FEVariable
+
+INTERFACE Sqrt
+ MODULE PURE FUNCTION fevar_sqrt(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariable_) :: ans
+ END FUNCTION fevar_sqrt
+END INTERFACE Sqrt
+
+!----------------------------------------------------------------------------
+! Norm2@UnaryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = NORM2(FEVariable)
+
+INTERFACE Norm2
+ MODULE PURE FUNCTION fevar_norm2(obj) RESULT(ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariable_) :: ans
+ END FUNCTION fevar_norm2
+END INTERFACE Norm2
+
+!----------------------------------------------------------------------------
+! InquiryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = NORM2(FEVariable)
+
+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 OPERATOR(.EQ.)
+
+!----------------------------------------------------------------------------
+! InquiryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-12
+! summary: FEVariable = NORM2(FEVariable)
+
+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 OPERATOR(.NE.)
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_UnaryMethod
diff --git a/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90 b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90
new file mode 100644
index 000000000..efdbca984
--- /dev/null
+++ b/src/modules/FEVariable/src/FEVariable_VectorInterpolationMethod.F90
@@ -0,0 +1,410 @@
+! 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 FEVariable_VectorInterpolationMethod
+USE BaseType, ONLY: FEVariable_, &
+ FEVariableVector_, &
+ FEVariableConstant_, &
+ FEVariableSpace_, &
+ FEVariableTime_, &
+ FEVariableSpaceTime_, &
+ TypeFEVariableOpt
+
+USE GlobalData, ONLY: I4B, DFP, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorConstantGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, ans, nrow, &
+ ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ END SUBROUTINE VectorConstantGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, constant
+!
+!# Introduction
+!
+! ans%s(1) and obj%s(1) should be same
+! ans%s(2) and nips should be same
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorConstantGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index for ans
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value in FEVariable form
+ !! Size of ans should be at least nips
+ END SUBROUTINE VectorConstantGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@InterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, constant
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorConstantGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, &
+ ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableConstant_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ END SUBROUTINE VectorConstantGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, ans, nrow, &
+ ncol)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ END SUBROUTINE VectorSpaceGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, scale, addContribution, timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index for ans
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ END SUBROUTINE VectorSpaceGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorSpaceGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, scale, addContribution, &
+ ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpace_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ END SUBROUTINE VectorSpaceGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_1( &
+ obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, &
+ ans, nrow, ncol, timeIndx)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Number of data written in ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is used when varType is spaceTime and defined on Quad
+ END SUBROUTINE VectorSpaceTimeGetInterpolation_1
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space-time
+!
+!# Introduction
+!
+! When obj%vartype is Nodal:
+! - Convert nodal values to quadrature values by using N
+! - make sure nns .LE. obj%len
+! - obj%s(1) denotes the nsd in obj
+! - obj%s(2) should be equal to nns
+! - obj%s(3) should be atleast nnt
+!
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_2( &
+ obj, rank, vartype, N, nns, nips, T, nnt, scale, addContribution, &
+ timeIndx, ans)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: nips
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(IN) :: timeIndx
+ !! time index is used when varType is spaceTime and defined on Quad
+ TYPE(FEVariable_), INTENT(INOUT) :: ans
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ END SUBROUTINE VectorSpaceTimeGetInterpolation_2
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorSpaceTimeGetInterpolation_3( &
+ obj, rank, vartype, N, nns, spaceIndx, timeIndx, T, nnt, scale, &
+ addContribution, ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ TYPE(FEVariableSpaceTime_), INTENT(IN) :: vartype
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ END SUBROUTINE VectorSpaceTimeGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_@VectorInterpolationMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-08-29
+! summary: Get interpolation of Vector, space-time
+
+INTERFACE GetInterpolation_
+ MODULE PURE SUBROUTINE VectorGetInterpolation_3( &
+ obj, rank, N, nns, spaceIndx, timeIndx, T, nnt, scale, addContribution, &
+ ans, tsize)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ TYPE(FEVariableVector_), INTENT(IN) :: rank
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! shape functions data, N(I, ips) : I is node or dof number
+ !! ips is integration point number
+ INTEGER(I4B), INTENT(IN) :: nns
+ !! number of nodes in N, bound for dim1 in N
+ INTEGER(I4B), INTENT(IN) :: spaceIndx, timeIndx
+ !! number of integration points in N, bound for dim2 in N
+ REAL(DFP), INTENT(IN) :: T(:)
+ !! time shape functions data, T(a) : a is time node or dof number
+ INTEGER(I4B), INTENT(IN) :: nnt
+ !! number of time nodes in T, bound for dim1 in T
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Interpolated value
+ !! Size of ans should be at least nips
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale factor to be applied to the interpolated value
+ LOGICAL(LGT), INTENT(IN) :: addContribution
+ !! if true, the interpolated value is added to ans
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! Number of data written in ans
+ END SUBROUTINE VectorGetInterpolation_3
+END INTERFACE GetInterpolation_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE FEVariable_VectorInterpolationMethod
diff --git a/src/modules/FPL/src/FPL_utils.F90 b/src/modules/FPL/src/FPL_utils.F90
index 978416506..c54472f0d 100644
--- a/src/modules/FPL/src/FPL_utils.F90
+++ b/src/modules/FPL/src/FPL_utils.F90
@@ -15,9 +15,9 @@
! along with this program. If not, see
!
-module FPL_Utils
-USE PENF, only: I1P, I4P
-contains
+MODULE FPL_Utils
+USE PENF, ONLY: I1P, I4P
+CONTAINS
!----------------------------------------------------------------------------
!
@@ -27,19 +27,19 @@ module FPL_Utils
! date: 2022-12-02
! summary: Procedure for computing the number of bytes of a logical variable.
-elemental function byte_size_logical(l) result(bytes)
- logical, intent(IN) :: l
+ELEMENTAL FUNCTION byte_size_logical(l) RESULT(bytes)
+ LOGICAL, INTENT(IN) :: l
!! Character variable whose number of bits must be computed.
- integer(I4P) :: bytes
+ INTEGER(I4P) :: bytes
!! Number of bits of l.
- integer(I1P) :: mold(1)
+ INTEGER(I1P) :: mold(1)
!! "Molding" dummy variable for bits counting.
- bytes = size(transfer(l, mold), dim=1, kind=I1P)
- return
-end function byte_size_logical
+ bytes = SIZE(TRANSFER(l, mold), dim=1, kind=I1P)
+ RETURN
+END FUNCTION byte_size_logical
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-end module FPL_Utils
+END MODULE FPL_Utils
diff --git a/src/modules/FPL/src/ParameterList.F90 b/src/modules/FPL/src/ParameterList.F90
index aec8a6919..0dd1076ad 100644
--- a/src/modules/FPL/src/ParameterList.F90
+++ b/src/modules/FPL/src/ParameterList.F90
@@ -136,27 +136,27 @@ MODULE ParameterList
ParameterList_isAssignable6D, &
ParameterList_isAssignable7D
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: DataSizeInBytes => &
- & ParameterList_DataSizeInBytes
+ ParameterList_DataSizeInBytes
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Del => ParameterList_RemoveEntry
GENERIC, PUBLIC :: Remove => Del
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Init => ParameterList_Init
GENERIC, PUBLIC :: Initiate => Init
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetShape => ParameterList_GetShape
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetDimensions => &
- & ParameterList_GetDimensions
+ ParameterList_GetDimensions
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: NewSubList => ParameterList_NewSubList
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetSubList => ParameterList_GetSubList
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: isPresent => ParameterList_isPresent
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: isSubList => ParameterList_isSubList
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetAsString => &
- & ParameterList_GetAsString
+ ParameterList_GetAsString
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Free => ParameterList_Free
GENERIC, PUBLIC :: DEALLOCATE => Free
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: PRINT => ParameterList_Print
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Display => ParameterList_Display
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: Length => ParameterList_Length
PROCEDURE, NON_OVERRIDABLE, PUBLIC :: GetIterator => &
- & ParameterList_GetIterator
+ ParameterList_GetIterator
FINAL :: ParameterList_Finalize
END TYPE ParameterList_t
@@ -200,30 +200,30 @@ MODULE ParameterList
PROCEDURE, NON_OVERRIDABLE :: GetEntry => ParameterListIterator_GetEntry
PROCEDURE, NON_OVERRIDABLE :: GetIndex => ParameterListIterator_GetIndex
PROCEDURE, NON_OVERRIDABLE :: PointToValue => &
- & ParameterListIterator_PointToValue
+ ParameterListIterator_PointToValue
PROCEDURE, NON_OVERRIDABLE :: NextNotEmptyListIterator => &
- & ParameterListIterator_NextNotEmptyListIterator
+ ParameterListIterator_NextNotEmptyListIterator
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetKey => ParameterListIterator_GetKey
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Init => ParameterListIterator_Init
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Begin => ParameterListIterator_Begin
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: END => ParameterListIterator_End
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Next => ParameterListIterator_Next
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: HasFinished => &
- & ParameterListIterator_HasFinished
+ ParameterListIterator_HasFinished
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetShape => &
- & ParameterListIterator_GetShape
+ ParameterListIterator_GetShape
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetDimensions => &
- & ParameterListIterator_GetDimensions
+ ParameterListIterator_GetDimensions
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: DataSizeInBytes => &
- & ParameterListIterator_DataSizeInBytes
+ ParameterListIterator_DataSizeInBytes
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetAsString => &
- & ParameterListIterator_GetAsString
+ ParameterListIterator_GetAsString
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: GetSubList => &
- & ParameterListIterator_GetSubList
+ ParameterListIterator_GetSubList
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: isSubList => &
- & ParameterListIterator_isSubList
+ ParameterListIterator_isSubList
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: toString => &
- & ParameterListIterator_toString
+ ParameterListIterator_toString
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: PRINT => ParameterListIterator_Print
PROCEDURE, PUBLIC, NON_OVERRIDABLE :: Free => ParameterListIterator_Free
GENERIC, PUBLIC :: Get => ParameterListIterator_Get0D, &
@@ -364,21 +364,19 @@ END SUBROUTINE ParameterList_Finalize
!
!----------------------------------------------------------------------------
-
!> author: Vikas Sharma, Ph. D.
-! date: 2023-09-22
+! date: 2023-09-22
! summary: Set a Key/Value pair into the dictionary
FUNCTION ParameterList_NewSubList(this, Key, Size) RESULT(SubListPointer)
-
- CLASS(ParameterList_t), INTENT(INOUT) :: this
+ CLASS(ParameterList_t), INTENT(INOUT) :: this
!! Parameter List
- CHARACTER(*), INTENT(IN) :: Key
+ CHARACTER(*), INTENT(IN) :: Key
!! String Key
- INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size
+ INTEGER(I4P), OPTIONAL, INTENT(IN) :: Size
!! Sublist Size
- TYPE(ParameterList_t), POINTER :: SublistPointer
+ TYPE(ParameterList_t), POINTER :: SublistPointer
!! New Sublist pointer
! Internal variables
@@ -431,7 +429,7 @@ FUNCTION ParameterList_GetSublist(this, Key, Sublist) RESULT(FPLerror)
END FUNCTION ParameterList_GetSubList
!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
FUNCTION ParameterList_Set0D(this, Key, VALUE) RESULT(FPLerror)
@@ -1656,13 +1654,14 @@ END FUNCTION ParameterList_GetAsString
!
!----------------------------------------------------------------------------
-SUBROUTINE ParameterList_Display(this, msg, unitno)
-
- !< Print the content of the DataBase
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-07-20
+! summary: Print the content of the DataBase
- CLASS(ParameterList_t), INTENT(in) :: this
- CHARACTER(*), INTENT(in) :: msg
- INTEGER(i4p), OPTIONAL, INTENT(in) :: unitno
+SUBROUTINE ParameterList_Display(this, msg, unitno)
+ CLASS(ParameterList_t), INTENT(IN) :: this
+ CHARACTER(*), INTENT(IN) :: msg
+ INTEGER(i4p), OPTIONAL, INTENT(IN) :: unitno
CALL this%PRINT(unitno, msg)
END SUBROUTINE ParameterList_Display
@@ -1760,8 +1759,10 @@ SUBROUTINE ParameterListIterator_Assignment(this, ParameterListIterator)
!< Dictionary iterator Assignment
- CLASS(ParameterListIterator_t), INTENT(INOUT) :: this ! Output Dictionary iterator
- TYPE(ParameterListIterator_t), INTENT(IN) :: ParameterListIterator ! Input Dictionary iterator
+ CLASS(ParameterListIterator_t), INTENT(INOUT) :: this
+ !! Output Dictionary iterator
+ TYPE(ParameterListIterator_t), INTENT(IN) :: ParameterListIterator
+ !! Input Dictionary iterator
this%DataBase(0:) => ParameterListIterator%DataBase
this%EntryListIterator = ParameterListIterator%EntryListIterator
@@ -1859,7 +1860,7 @@ SUBROUTINE ParameterListIterator_Next(this)
END SUBROUTINE ParameterListIterator_Next
!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
FUNCTION ParameterListIterator_GetEntry(this) RESULT(CurrentEntry)
@@ -1880,7 +1881,7 @@ FUNCTION ParameterListIterator_GetEntry(this) RESULT(CurrentEntry)
END FUNCTION ParameterListIterator_GetEntry
!----------------------------------------------------------------------------
-!
+!
!----------------------------------------------------------------------------
FUNCTION ParameterListIterator_PointToValue(this) RESULT(VALUE)
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90
index 0220fa6c8..49555558c 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I4P.F90
@@ -18,199 +18,188 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper0D_I4P
+MODULE DimensionsWrapper0D_I4P
USE DimensionsWrapper0D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I4P_t
- integer(I4P), allocatable :: Value
- contains
- private
- procedure, public :: Set => DimensionsWrapper0D_I4P_Set
- procedure, public :: Get => DimensionsWrapper0D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper0D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper0D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper0D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper0D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper0D_I4P_toString
- procedure, public :: Free => DimensionsWrapper0D_I4P_Free
- procedure, public :: Print => DimensionsWrapper0D_I4P_Print
- final :: DimensionsWrapper0D_I4P_Final
- end type
-
-public :: DimensionsWrapper0D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper0D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper0D
- !-----------------------------------------------------------------
- type(DimensionsWrapper0D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value, stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- Value = this%Value
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Return the shape of the Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper0D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper0D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value
- !-----------------------------------------------------------------
- allocate(Value, source = this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper0D
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper0D_I4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this !< Dimensions wrapper 0D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%Value)
- end function DimensionsWrapper0D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper0D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this !< Dimensions wrapper 0D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper0D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper0D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
- if(allocated(this%Value)) String = trim(str(n=this%Value))
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper0D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_I4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_I4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_I4P_Print
+ FINAL :: DimensionsWrapper0D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper0D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper0D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper0D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE, stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ VALUE = this%VALUE
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Return the shape of the Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper0D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE, source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE)
+END FUNCTION DimensionsWrapper0D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper0D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper0D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper0D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
+ IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE))
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper0D_I4P_Print
-
-end module DimensionsWrapper0D_I4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper0D_I4P_Print
+
+END MODULE DimensionsWrapper0D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90
index bbc8b0a38..ed79da75a 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_I8P.F90
@@ -18,200 +18,188 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper0D_I8P
+MODULE DimensionsWrapper0D_I8P
USE DimensionsWrapper0D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I8P_t
- integer(I8P), allocatable :: Value
- contains
- private
- procedure, public :: Set => DimensionsWrapper0D_I8P_Set
- procedure, public :: Get => DimensionsWrapper0D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper0D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper0D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper0D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper0D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper0D_I8P_toString
- procedure, public :: Free => DimensionsWrapper0D_I8P_Free
- procedure, public :: Print => DimensionsWrapper0D_I8P_Print
- final :: DimensionsWrapper0D_I8P_Final
- end type
-
-public :: DimensionsWrapper0D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper0D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper0D
- !-----------------------------------------------------------------
- type(DimensionsWrapper0D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value, stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- Value = this%Value
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Return the shape of the Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper0D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper0D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value
- !-----------------------------------------------------------------
- allocate(Value, source = this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper0D
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper0D_I8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this !< Dimensions wrapper 0D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%Value)
- end function DimensionsWrapper0D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper0D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this !< Dimensions wrapper 0D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper0D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper0D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
- if(allocated(this%Value)) String = trim(str(n=this%Value))
- end subroutine
-
-
- subroutine DimensionsWrapper0D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper0D_I8P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_I8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_I8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_I8P_Print
+ FINAL :: DimensionsWrapper0D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper0D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper0D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper0D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE, stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ VALUE = this%VALUE
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Return the shape of the Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper0D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE, source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE)
+END FUNCTION DimensionsWrapper0D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper0D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper0D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper0D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
+ IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE))
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper0D_I8P_Print
-
-
-end module DimensionsWrapper0D_I8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper0D_I8P_Print
+
+END MODULE DimensionsWrapper0D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90
index 1ba2b3c05..8a31fddf8 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_L.F90
@@ -18,201 +18,189 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper0D_L
+MODULE DimensionsWrapper0D_L
USE DimensionsWrapper0D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_L_t
- logical, allocatable :: Value
- contains
- private
- procedure, public :: Set => DimensionsWrapper0D_L_Set
- procedure, public :: Get => DimensionsWrapper0D_L_Get
- procedure, public :: GetShape => DimensionsWrapper0D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper0D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper0D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper0D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper0D_L_toString
- procedure, public :: Free => DimensionsWrapper0D_L_Free
- procedure, public :: Print => DimensionsWrapper0D_L_Print
- final :: DimensionsWrapper0D_L_Final
- end type
-
-public :: DimensionsWrapper0D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper0D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper0D
- !-----------------------------------------------------------------
- type(DimensionsWrapper0D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper0D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value, stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- Value = this%Value
- class Default
- call msg%Warn(txt='Getting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Return the shape of the Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper0D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper0D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value
- !-----------------------------------------------------------------
- allocate(Value, source = this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper0D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper0D
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper0D_L_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this !< Dimensions wrapper 0D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%Value)
- end function DimensionsWrapper0D_L_DataSizeInBytes
-
-
- function DimensionsWrapper0D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this !< Dimensions wrapper 0D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper0D_L_isOfDataType
-
-
- subroutine DimensionsWrapper0D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
- if(allocated(this%Value)) String = trim(str(n=this%Value))
- end subroutine
-
-
- subroutine DimensionsWrapper0D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper0D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => DimensionsWrapper0D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_L_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_L_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_L_Print
+ FINAL :: DimensionsWrapper0D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper0D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper0D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper0D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE, stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ VALUE = this%VALUE
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Return the shape of the Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper0D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE, source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size_logical(this%VALUE)
+END FUNCTION DimensionsWrapper0D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper0D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper0D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper0D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
+ IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE))
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper0D_L_Print
-
-
-end module DimensionsWrapper0D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper0D_L_Print
+
+END MODULE DimensionsWrapper0D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90
index ed9329027..36a96bbb6 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R4P.F90
@@ -18,199 +18,190 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper0D_R4P
+MODULE DimensionsWrapper0D_R4P
USE DimensionsWrapper0D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R4P_t
- real(R4P), allocatable :: Value
- contains
- private
- procedure, public :: Set => DimensionsWrapper0D_R4P_Set
- procedure, public :: Get => DimensionsWrapper0D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper0D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper0D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper0D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper0D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper0D_R4P_toString
- procedure, public :: Print => DimensionsWrapper0D_R4P_Print
- procedure, public :: Free => DimensionsWrapper0D_R4P_Free
- final :: DimensionsWrapper0D_R4P_Final
- end type
-
-public :: DimensionsWrapper0D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper0D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper0D
- !-----------------------------------------------------------------
- type(DimensionsWrapper0D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value, stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- Value = this%Value
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Return the shape of the Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper0D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper0D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value
- !-----------------------------------------------------------------
- allocate(Value, source = this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper0D
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper0D_r4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this !< Dimensions wrapper 0D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%Value)
- end function DimensionsWrapper0D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper0D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this !< Dimensions wrapper 0D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper0D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper0D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
- if(allocated(this%Value)) String = trim(str(n=this%Value))
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper0D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper0D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_R4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_R4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_R4P_Free
+ FINAL :: DimensionsWrapper0D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper0D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper0D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper0D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE, stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ VALUE = this%VALUE
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Return the shape of the Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper0D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE, source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_r4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE)
+END FUNCTION DimensionsWrapper0D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper0D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper0D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper0D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
+ IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE))
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper0D_R4P_Print
-
-end module DimensionsWrapper0D_R4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper0D_R4P_Print
+
+END MODULE DimensionsWrapper0D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90
index b93c5d148..3ef63084f 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper0D/DimensionsWrapper0D_R8P.F90
@@ -18,200 +18,190 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper0D_R8P
+MODULE DimensionsWrapper0D_R8P
USE DimensionsWrapper0D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R8P_t
- real(R8P), allocatable :: Value
- contains
- private
- procedure, public :: Set => DimensionsWrapper0D_R8P_Set
- procedure, public :: Get => DimensionsWrapper0D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper0D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper0D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper0D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper0D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper0D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper0D_R8P_toString
- procedure, public :: Free => DimensionsWrapper0D_R8P_Free
- procedure, public :: Print => DimensionsWrapper0D_R8P_Print
- final :: DimensionsWrapper0D_R8P_Final
- end type
-
-public :: DimensionsWrapper0D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper0D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper0D
- !-----------------------------------------------------------------
- type(DimensionsWrapper0D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value, stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- Value = this%Value
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Return the shape of the Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper0D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper0D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value
- !-----------------------------------------------------------------
- allocate(Value, source = this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper0D
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper0D_R8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored value
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this !< Dimensions wrapper 0D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%Value)
- end function DimensionsWrapper0D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper0D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this !< Dimensions wrapper 0D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper0D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper0D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
- if(allocated(this%Value)) String = trim(str(n=this%Value))
- end subroutine
-
-
- subroutine DimensionsWrapper0D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper0D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper0D_t) :: DimensionsWrapper0D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper0D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper0D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper0D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper0D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper0D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper0D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper0D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper0D_R8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper0D_R8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper0D_R8P_Print
+ FINAL :: DimensionsWrapper0D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper0D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper0D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper0D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE, stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ VALUE = this%VALUE
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Return the shape of the Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper0D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE, source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper0D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper0D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE)
+END FUNCTION DimensionsWrapper0D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper0D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 0D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper0D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper0D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
+ IF (ALLOCATED(this%VALUE)) String = TRIM(str(n=this%VALUE))
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper0D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper0D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper0D_R8P_Print
-
-
-end module DimensionsWrapper0D_R8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper0D_R8P_Print
+
+END MODULE DimensionsWrapper0D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90
index e011507fc..ec29ee82e 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_I4P.F90
@@ -18,209 +18,198 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper1D_I4P
+MODULE DimensionsWrapper1D_I4P
USE DimensionsWrapper1D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I4P_t
- integer(I4P), allocatable :: Value(:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper1D_I4P_Set
- procedure, public :: Get => DimensionsWrapper1D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper1D_I4P_GetShape
- procedure, public :: GetPolymorphic => DimensionsWrapper1D_I4P_GetPolymorphic
- procedure, public :: GetPointer => DimensionsWrapper1D_I4P_GetPointer
- procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper1D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper1D_I4P_toString
- procedure, public :: Free => DimensionsWrapper1D_I4P_Free
- procedure, public :: Print => DimensionsWrapper1D_I4P_Print
- final :: DimensionsWrapper1D_I4P_Final
- end type
-
-public :: DimensionsWrapper1D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper1D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper1D
- !-----------------------------------------------------------------
- type(DimensionsWrapper1D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper1D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1)), stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper1D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic W2apper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper1D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1)),source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper1D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper1D
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper1D_I4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this !< Dimensions wrapper 1D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1))*size(this%value)
- end function DimensionsWrapper1D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper1D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this !< Dimensions wrapper 1D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper1D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper1D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper1D_I4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_I4P_GetPointer
+procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_I4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_I4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_I4P_Print
+ FINAL :: DimensionsWrapper1D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper1D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper1D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper1D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic W2apper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper1D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper1D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper1D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper1D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper1D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
if(allocated(this%Value)) String = trim(str(n=this%Value, separator=Separator))
- end subroutine
-
-
- subroutine DimensionsWrapper1D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper1D_I4P_Print
-
-end module DimensionsWrapper1D_I4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper1D_I4P_Print
+
+END MODULE DimensionsWrapper1D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90
index b6fa86fa3..0663892d8 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_L.F90
@@ -18,218 +18,208 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper1D_L
+MODULE DimensionsWrapper1D_L
USE DimensionsWrapper1D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_L_t
- logical, allocatable :: Value(:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper1D_L_Set
- procedure, public :: Get => DimensionsWrapper1D_L_Get
- procedure, public :: GetShape => DimensionsWrapper1D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper1D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper1D_L_GetPolymorphic
- procedure, public :: isOfDataType => DimensionsWrapper1D_L_isOfDataType
- procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_L_DataSizeInBytes
- procedure, public :: toString => DimensionsWrapper1D_L_toString
- procedure, public :: Free => DimensionsWrapper1D_L_Free
- procedure, public :: Print => DimensionsWrapper1D_L_Print
- final :: DimensionsWrapper1D_L_Final
- end type
-
-public :: DimensionsWrapper1D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper1D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper1D
- !-----------------------------------------------------------------
- type(DimensionsWrapper1D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper1D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1)), stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (logical)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper1D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic W2apper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper1D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1)),source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper1D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper1D
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper1D_L_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this !< Dimensions wrapper 1D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%value(1))*size(this%value)
- end function DimensionsWrapper1D_L_DataSizeInBytes
-
-
- function DimensionsWrapper1D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this !< Dimensions wrapper 1D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper1D_L_isOfDataType
-
-
- subroutine DimensionsWrapper1D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx=1, size(this%Value)
- String = String // trim(str(n=this%Value(idx))) // Sep
- enddo
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper1D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper1D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_L_isOfDataType
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper1D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_L_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_L_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_L_Print
+ FINAL :: DimensionsWrapper1D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper1D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper1D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper1D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic W2apper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper1D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size_logical(this%VALUE(1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper1D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper1D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper1D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper1D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx = 1, SIZE(this%VALUE)
+ String = String//TRIM(str(n=this%VALUE(idx)))//Sep
+ END DO
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper1D_L_Print
-
-end module DimensionsWrapper1D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper1D_L_Print
+
+END MODULE DimensionsWrapper1D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90
index 05f3d5c20..89d6769d6 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R4P.F90
@@ -18,208 +18,199 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper1D_R4P
+MODULE DimensionsWrapper1D_R4P
USE DimensionsWrapper1D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R4P_t
- real(R4P), allocatable :: Value(:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper1D_R4P_Set
- procedure, public :: Get => DimensionsWrapper1D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper1D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper1D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper1D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper1D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper1D_R4P_toString
- procedure, public :: Free => DimensionsWrapper1D_R4P_Free
- procedure, public :: Print => DimensionsWrapper1D_R4P_Print
- final :: DimensionsWrapper1D_R4P_Final
- end type
-
-public :: DimensionsWrapper1D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper1D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper1D
- !-----------------------------------------------------------------
- type(DimensionsWrapper1D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1)), stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper1D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic W2apper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper1D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1)),source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper1D
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper1D_R4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this !< Dimensions wrapper 1D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1))*size(this%value)
- end function DimensionsWrapper1D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper1D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this !< Dimensions wrapper 1D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper1D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper1D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper1D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper1D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_R4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_R4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_R4P_Print
+ FINAL :: DimensionsWrapper1D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper1D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper1D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper1D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic W2apper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper1D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper1D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper1D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper1D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper1D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
if(allocated(this%Value)) String = trim(str(n=this%Value, separator=Separator))
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper1D_R4P_Print
-
-end module DimensionsWrapper1D_R4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper1D_R4P_Print
+
+END MODULE DimensionsWrapper1D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90
index fa590fca8..bb7aa155e 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper1D/DimensionsWrapper1D_R8P.F90
@@ -18,208 +18,198 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper1D_R8P
-
+MODULE DimensionsWrapper1D_R8P
USE DimensionsWrapper1D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R8P_t
- real(R8P), allocatable :: Value(:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper1D_R8P_Set
- procedure, public :: Get => DimensionsWrapper1D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper1D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper1D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper1D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper1D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper1D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper1D_R8P_toString
- procedure, public :: Free => DimensionsWrapper1D_R8P_Free
- procedure, public :: Print => DimensionsWrapper1D_R8P_Print
- final :: DimensionsWrapper1D_R8P_Final
- end type
-
-public :: DimensionsWrapper1D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper1D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper1D
- !-----------------------------------------------------------------
- type(DimensionsWrapper1D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1)), stat=err)
- this%Value = Value
- if(err/=0) call msg%Error(txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn(txt='Setting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper1D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic W2apper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper1D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1)),source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper1D
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper1D_R8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this !< Dimensions wrapper 1D
- integer(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1))*size(this%value)
- end function DimensionsWrapper1D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper1D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this !< Dimensions wrapper 1D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper1D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper1D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- !-----------------------------------------------------------------
- String = ''
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper1D_t) :: DimensionsWrapper1D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper1D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper1D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper1D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper1D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper1D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper1D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper1D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper1D_R8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper1D_R8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper1D_R8P_Print
+ FINAL :: DimensionsWrapper1D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper1D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper1D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper1D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1)), stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic W2apper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper1D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1)), source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper1D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper1D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ INTEGER(I4P) :: DataSizeInBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper1D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper1D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 1D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper1D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper1D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ !-----------------------------------------------------------------
+ String = ''
if(allocated(this%Value)) String = trim(str(n=this%Value, separator=Separator))
- end subroutine
-
-
- subroutine DimensionsWrapper1D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper1D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
- call this%toString(strvalue)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper1D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper1D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
+ CALL this%toString(strvalue)
write(unit=unit,fmt='(A)',iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '//strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper1D_R8P_Print
-
-end module DimensionsWrapper1D_R8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '//strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper1D_R8P_Print
+
+END MODULE DimensionsWrapper1D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90
index a2259c9f2..87c038a5c 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I4P.F90
@@ -18,223 +18,212 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper2D_I4P
+MODULE DimensionsWrapper2D_I4P
USE DimensionsWrapper2D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I4P_t
- integer(I4P), allocatable :: Value(:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper2D_I4P_Set
- procedure, public :: Get => DimensionsWrapper2D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper2D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper2D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper2D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I4P_DataSizeInBytes
- procedure, public :: toString => DimensionsWrapper2D_I4P_toString
- procedure, public :: isOfDataType => DimensionsWrapper2D_I4P_isOfDataType
- procedure, public :: Free => DimensionsWrapper2D_I4P_Free
- procedure, public :: Print => DimensionsWrapper2D_I4P_Print
- final :: DimensionsWrapper2D_I4P_Final
- end type
-
-public :: DimensionsWrapper2D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper2D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper2D
- !-----------------------------------------------------------------
- type(DimensionsWrapper2D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper2D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper2D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper2D
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper2D_I4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this !< Dimensions wrapper 2D
- integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1))*size(this%value)
- end function DimensionsWrapper2D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper2D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this !< Dimensions wrapper 2D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper2D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper2D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx))) // Sep
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper2D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_I4P_toString
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_I4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_I4P_Print
+ FINAL :: DimensionsWrapper2D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper2D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper2D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper2D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper2D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper2D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper2D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper2D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper2D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true.,n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper2D_I4P_Print
-
-end module DimensionsWrapper2D_I4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper2D_I4P_Print
+
+END MODULE DimensionsWrapper2D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90
index dec2da4ae..2543623aa 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_I8P.F90
@@ -18,224 +18,213 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper2D_I8P
+MODULE DimensionsWrapper2D_I8P
USE DimensionsWrapper2D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I8P_t
- integer(I8P), allocatable :: Value(:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper2D_I8P_Set
- procedure, public :: Get => DimensionsWrapper2D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper2D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper2D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper2D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper2D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper2D_I8P_toString
- procedure, public :: Free => DimensionsWrapper2D_I8P_Free
- procedure, public :: Print => DimensionsWrapper2D_I8P_Print
- final :: DimensionsWrapper2D_I8P_Final
- end type
-
-public :: DimensionsWrapper2D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper2D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper2D
- !-----------------------------------------------------------------
- type(DimensionsWrapper2D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper2D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper2D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper2D
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper2D_I8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this !< Dimensions wrapper 2D
- integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1))*size(this%value)
- end function DimensionsWrapper2D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper2D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this !< Dimensions wrapper 2D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper2D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper2D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx))) // Sep
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper2D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE(:, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper2D_I8P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_I8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_I8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_I8P_Print
+ FINAL :: DimensionsWrapper2D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper2D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper2D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper2D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper2D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper2D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper2D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper2D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper2D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper2D_I8P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper2D_I8P_Print
-end module DimensionsWrapper2D_I8P
+END MODULE DimensionsWrapper2D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90
index 65389e615..7889b0391 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_L.F90
@@ -18,226 +18,216 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper2D_L
+MODULE DimensionsWrapper2D_L
USE DimensionsWrapper2D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_L_t
- logical, allocatable :: Value(:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper2D_L_Set
- procedure, public :: Get => DimensionsWrapper2D_L_Get
- procedure, public :: GetShape => DimensionsWrapper2D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper2D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper2D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper2D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper2D_L_toString
- procedure, public :: Free => DimensionsWrapper2D_L_Free
- procedure, public :: Print => DimensionsWrapper2D_L_Print
- final :: DimensionsWrapper2D_L_Final
- end type
-
-public :: DimensionsWrapper2D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper2D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper2D
- !-----------------------------------------------------------------
- type(DimensionsWrapper2D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper2D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper2D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper2D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper2D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper2D
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper2D_L_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this !< Dimensions wrapper 2D
- integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%value(1,1))*size(this%value)
- end function DimensionsWrapper2D_L_DataSizeInBytes
-
-
- function DimensionsWrapper2D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this !< Dimensions wrapper 2D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper2D_L_isOfDataType
-
-
- subroutine DimensionsWrapper2D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx1,idx2
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx2=1, size(this%Value,2)
- do idx1=1, size(this%Value,1)
- String = String // trim(str(n=this%Value(idx1,idx2))) // Sep
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper2D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper2D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper2D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_L_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_L_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_L_Print
+ FINAL :: DimensionsWrapper2D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper2D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper2D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper2D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper2D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size_logical(this%VALUE(1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper2D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper2D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper2D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper2D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx1, idx2
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ DO idx1 = 1, SIZE(this%VALUE, 1)
+ String = String//TRIM(str(n=this%VALUE(idx1, idx2)))//Sep
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper2D_L_Print
-
-end module DimensionsWrapper2D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper2D_L_Print
+
+END MODULE DimensionsWrapper2D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90
index 6b9f749f5..cf0141077 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R4P.F90
@@ -18,224 +18,215 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper2D_R4P
+MODULE DimensionsWrapper2D_R4P
USE DimensionsWrapper2D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R4P_t
- real(R4P), allocatable :: Value(:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper2D_R4P_Set
- procedure, public :: Get => DimensionsWrapper2D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper2D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper2D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper2D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper2D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper2D_R4P_toString
- procedure, public :: Free => DimensionsWrapper2D_R4P_Free
- procedure, public :: Print => DimensionsWrapper2D_R4P_Print
- final :: DimensionsWrapper2D_R4P_Final
- end type
-
-public :: DimensionsWrapper2D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper2D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper2D
- !-----------------------------------------------------------------
- type(DimensionsWrapper2D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper2D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper2D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper2D
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper2D_R4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this !< Dimensions wrapper 2D
- integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1))*size(this%value)
- end function DimensionsWrapper2D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper2D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this !< Dimensions wrapper 2D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper2D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper2D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx))) // Sep
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper2D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper2D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_R4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_R4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_R4P_Print
+ FINAL :: DimensionsWrapper2D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper2D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper2D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper2D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper2D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper2D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper2D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper2D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper2D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper2D_R4P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper2D_R4P_Print
-end module DimensionsWrapper2D_R4P
+END MODULE DimensionsWrapper2D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90
index 9d8fbd362..82f5b24ab 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper2D/DimensionsWrapper2D_R8P.F90
@@ -18,224 +18,214 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper2D_R8P
-
+MODULE DimensionsWrapper2D_R8P
USE DimensionsWrapper2D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R8P_t
- real(R8P), allocatable :: Value(:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper2D_R8P_Set
- procedure, public :: Get => DimensionsWrapper2D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper2D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper2D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper2D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper2D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper2D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper2D_R8P_toString
- procedure, public :: Free => DimensionsWrapper2D_R8P_Free
- procedure, public :: Print => DimensionsWrapper2D_R8P_Print
- final :: DimensionsWrapper2D_R8P_Final
- end type
-
-public :: DimensionsWrapper2D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper2D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper2D
- !-----------------------------------------------------------------
- type(DimensionsWrapper2D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper2D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:)
- !-----------------------------------------------------------------
- Value => this%value
- end function
-
-
- subroutine DimensionsWrapper2D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper2D
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper2D_R8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this !< Dimensions wrapper 2D
- integer(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1))*size(this%value)
- end function DimensionsWrapper2D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper2D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this !< Dimensions wrapper 2D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper2D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper2D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx))) // Sep
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper2D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper2D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper2D_t) :: DimensionsWrapper2D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper2D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper2D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper2D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper2D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper2D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper2D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper2D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper2D_R8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper2D_R8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper2D_R8P_Print
+ FINAL :: DimensionsWrapper2D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper2D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper2D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper2D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper2D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper2D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper2D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ INTEGER(I4P) :: DataSizeinBytes !< Size in bytes of the stored data
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper2D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper2D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 2D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper2D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper2D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx)))//Sep
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper2D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper2D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper2D_R8P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper2D_R8P_Print
-end module DimensionsWrapper2D_R8P
+END MODULE DimensionsWrapper2D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90
index 880940708..1e35d3d2f 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I4P.F90
@@ -18,228 +18,217 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper3D_I4P
+MODULE DimensionsWrapper3D_I4P
USE DimensionsWrapper3D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I4P_t
- integer(I4P), allocatable :: Value(:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper3D_I4P_Set
- procedure, public :: Get => DimensionsWrapper3D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper3D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper3D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper3D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper3D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper3D_I4P_toString
- procedure, public :: Free => DimensionsWrapper3D_I4P_Free
- procedure, public :: Print => DimensionsWrapper3D_I4P_Print
- final :: DimensionsWrapper3D_I4P_Final
- end type
-
-public :: DimensionsWrapper3D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper3D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper3D
- !-----------------------------------------------------------------
- type(DimensionsWrapper3D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper3D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper3D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper3D
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper3D_I4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this !< Dimensions wrapper 3D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value)
- end function DimensionsWrapper3D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper3D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this !< Dimensions wrapper 3D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper3D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper3D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper3D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_I4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_I4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_I4P_Print
+ FINAL :: DimensionsWrapper3D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper3D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper3D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper3D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper3D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper3D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper3D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper3D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper3D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper3D_I4P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper3D_I4P_Print
-end module DimensionsWrapper3D_I4P
+END MODULE DimensionsWrapper3D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90
index 385d0299e..1cc9c9958 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_I8P.F90
@@ -18,228 +18,217 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper3D_I8P
+MODULE DimensionsWrapper3D_I8P
USE DimensionsWrapper3D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I8P_t
- integer(I8P), allocatable :: Value(:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper3D_I8P_Set
- procedure, public :: Get => DimensionsWrapper3D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper3D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper3D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper3D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper3D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper3D_I8P_toString
- procedure, public :: Free => DimensionsWrapper3D_I8P_Free
- procedure, public :: Print => DimensionsWrapper3D_I8P_Print
- final :: DimensionsWrapper3D_I8P_Final
- end type
-
-public :: DimensionsWrapper3D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper3D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper3D
- !-----------------------------------------------------------------
- type(DimensionsWrapper3D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper3D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper3D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper3D
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper3D_I8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this !< Dimensions wrapper 3D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value)
- end function DimensionsWrapper3D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper3D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this !< Dimensions wrapper 3D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper3D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper3D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper3D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper3D_I8P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_I8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_I8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_I8P_Print
+ FINAL :: DimensionsWrapper3D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper3D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper3D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper3D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper3D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper3D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper3D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper3D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper3D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper3D_I8P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper3D_I8P_Print
-end module DimensionsWrapper3D_I8P
+END MODULE DimensionsWrapper3D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90
index dad4c1c13..3ce39f6de 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_L.F90
@@ -18,230 +18,220 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper3D_L
+MODULE DimensionsWrapper3D_L
USE DimensionsWrapper3D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_L_t
- logical, allocatable :: Value(:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper3D_L_Set
- procedure, public :: Get => DimensionsWrapper3D_L_Get
- procedure, public :: GetShape => DimensionsWrapper3D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper3D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper3D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper3D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper3D_L_toString
- procedure, public :: Free => DimensionsWrapper3D_L_Free
- procedure, public :: Print => DimensionsWrapper3D_L_Print
- final :: DimensionsWrapper3D_L_Final
- end type
-
-public :: DimensionsWrapper3D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper3D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper3D
- !-----------------------------------------------------------------
- type(DimensionsWrapper3D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper3D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper3D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper3D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper3D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper3D
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper3D_L_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this !< Dimensions wrapper 3D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%value(1,1,1))*size(this%value)
- end function DimensionsWrapper3D_L_DataSizeInBytes
-
-
- function DimensionsWrapper3D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this !< Dimensions wrapper 3D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper3D_L_isOfDataType
-
-
- subroutine DimensionsWrapper3D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx1,idx2,idx3
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- do idx1=1, size(this%Value,1)
- String = String // trim(str(n=this%Value(idx1,idx2,idx3))) // Sep
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper3D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper3D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper3D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_L_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_L_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_L_Print
+ FINAL :: DimensionsWrapper3D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper3D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper3D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper3D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS DEFAULT
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper3D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size_logical(this%VALUE(1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper3D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper3D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper3D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper3D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx1, idx2, idx3
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ DO idx1 = 1, SIZE(this%VALUE, 1)
+ String = String//TRIM(str(n=this%VALUE(idx1, idx2, idx3)))//Sep
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper3D_L_Print
-
-end module DimensionsWrapper3D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper3D_L_Print
+
+END MODULE DimensionsWrapper3D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90
index 134fc66ab..ba2345933 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R4P.F90
@@ -18,227 +18,217 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper3D_R4P
-
+MODULE DimensionsWrapper3D_R4P
USE DimensionsWrapper3D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R4P_t
- real(R4P), allocatable :: Value(:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper3D_R4P_Set
- procedure, public :: Get => DimensionsWrapper3D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper3D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper3D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper3D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper3D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper3D_R4P_toString
- procedure, public :: Free => DimensionsWrapper3D_R4P_Free
- procedure, public :: Print => DimensionsWrapper3D_R4P_Print
- final :: DimensionsWrapper3D_R4P_Final
- end type
-
-public :: DimensionsWrapper3D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper3D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper3D
- !-----------------------------------------------------------------
- type(DimensionsWrapper3D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper3D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper3D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper3D
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper3D_R4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this !< Dimensions wrapper 3D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value)
- end function DimensionsWrapper3D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper3D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this !< Dimensions wrapper 3D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper3D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper3D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper3D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper3D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_R4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_R4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_R4P_Print
+ FINAL :: DimensionsWrapper3D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper3D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper3D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper3D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper3D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper3D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper3D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper3D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper3D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper3D_R4P_Print
-
-end module DimensionsWrapper3D_R4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper3D_R4P_Print
+
+END MODULE DimensionsWrapper3D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90
index c349fdf60..dce85f477 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper3D/DimensionsWrapper3D_R8P.F90
@@ -18,228 +18,218 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper3D_R8P
-
+MODULE DimensionsWrapper3D_R8P
USE DimensionsWrapper3D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R8P_t
- real(R8P), allocatable :: Value(:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper3D_R8P_Set
- procedure, public :: Get => DimensionsWrapper3D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper3D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper3D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper3D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper3D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper3D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper3D_R8P_toString
- procedure, public :: Free => DimensionsWrapper3D_R8P_Free
- procedure, public :: Print => DimensionsWrapper3D_R8P_Print
- final :: DimensionsWrapper3D_R8P_Final
- end type
-
-public :: DimensionsWrapper3D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper3D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper3D
- !-----------------------------------------------------------------
- type(DimensionsWrapper3D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper3D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper3D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper3D
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper3D_R8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size in bytes of the stored data
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this !< Dimensions wrapper 3D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1))*size(this%value)
- end function DimensionsWrapper3D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper3D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this !< Dimensions wrapper 3D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper3D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper3D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3))) // Sep
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper3D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper3D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper3D_t) :: DimensionsWrapper3D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper3D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper3D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper3D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper3D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper3D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper3D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper3D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper3D_R8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper3D_R8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper3D_R8P_Print
+ FINAL :: DimensionsWrapper3D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper3D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper3D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper3D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper3D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper3D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper3D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size in bytes of the stored data
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper3D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper3D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 3D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper3D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper3D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3)))//Sep
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper3D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper3D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper3D_R8P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper3D_R8P_Print
-end module DimensionsWrapper3D_R8P
+END MODULE DimensionsWrapper3D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90
index 9b3ff11dd..c9b842649 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I4P.F90
@@ -18,232 +18,221 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper4D_I4P
+MODULE DimensionsWrapper4D_I4P
USE DimensionsWrapper4D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I4P_t
- integer(I4P), allocatable :: Value(:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper4D_I4P_Set
- procedure, public :: Get => DimensionsWrapper4D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper4D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper4D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper4D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper4D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper4D_I4P_toString
- procedure, public :: Print => DimensionsWrapper4D_I4P_Print
- procedure, public :: Free => DimensionsWrapper4D_I4P_Free
- final :: DimensionsWrapper4D_I4P_Final
- end type
-
-public :: DimensionsWrapper4D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper4D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper4D
- !-----------------------------------------------------------------
- type(DimensionsWrapper4D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper4D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper4D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper4D
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper4D_I4P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the data size of the stored value in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this !< Dimensions wrapper 4D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value)
- end function DimensionsWrapper4D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper4D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this !< Dimensions wrapper 4D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper4D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper4D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper4D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_I4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_I4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_I4P_Free
+ FINAL :: DimensionsWrapper4D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper4D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper4D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper4D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper4D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_I4P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the data size of the stored value in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper4D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper4D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper4D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper4D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper4D_I4P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper4D_I4P_Print
-end module DimensionsWrapper4D_I4P
+END MODULE DimensionsWrapper4D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90
index a14b3381d..979311a24 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_I8P.F90
@@ -18,233 +18,221 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper4D_I8P
+MODULE DimensionsWrapper4D_I8P
USE DimensionsWrapper4D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I8P_t
- integer(I8P), allocatable :: Value(:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper4D_I8P_Set
- procedure, public :: Get => DimensionsWrapper4D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper4D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper4D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper4D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper4D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper4D_I8P_toString
- procedure, public :: Print => DimensionsWrapper4D_I8P_Print
- procedure, public :: Free => DimensionsWrapper4D_I8P_Free
- final :: DimensionsWrapper4D_I8P_Final
- end type
-
-public :: DimensionsWrapper4D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper4D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper4D
- !-----------------------------------------------------------------
- type(DimensionsWrapper4D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper4D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
-
- subroutine DimensionsWrapper4D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper4D
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper4D_I8P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the data size of the stored value in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this !< Dimensions wrapper 4D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value)
- end function DimensionsWrapper4D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper4D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this !< Dimensions wrapper 4D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper4D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper4D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper4D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper4D_I8P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_I8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_I8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_I8P_Free
+ FINAL :: DimensionsWrapper4D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper4D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper4D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper4D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper4D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_I8P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the data size of the stored value in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper4D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper4D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper4D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper4D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper4D_I8P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper4D_I8P_Print
-end module DimensionsWrapper4D_I8P
+END MODULE DimensionsWrapper4D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90
index 9699fd431..d51d22414 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_L.F90
@@ -18,235 +18,225 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper4D_L
+MODULE DimensionsWrapper4D_L
USE DimensionsWrapper4D
USE FPL_Utils
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_L_t
- logical, allocatable :: Value(:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper4D_L_Set
- procedure, public :: Get => DimensionsWrapper4D_L_Get
- procedure, public :: GetShape => DimensionsWrapper4D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper4D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper4D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper4D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper4D_L_toString
- procedure, public :: Print => DimensionsWrapper4D_L_Print
- procedure, public :: Free => DimensionsWrapper4D_L_Free
- final :: DimensionsWrapper4D_L_Final
- end type
-
-public :: DimensionsWrapper4D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper4D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper4D
- !-----------------------------------------------------------------
- type(DimensionsWrapper4D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper4D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper4D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper4D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper4D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper4D
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper4D_L_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the data size of the stored value in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this !< Dimensions wrapper 4D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%value(1,1,1,1))*size(this%value)
- end function DimensionsWrapper4D_L_DataSizeInBytes
-
-
- function DimensionsWrapper4D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this !< Dimensions wrapper 4D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper4D_L_isOfDataType
-
-
- subroutine DimensionsWrapper4D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx1,idx2,idx3,idx4
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- do idx1=1, size(this%Value,1)
- String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4))) // Sep
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper4D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper4D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper4D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_L_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_L_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_L_Free
+ FINAL :: DimensionsWrapper4D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper4D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper4D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper4D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper4D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_L_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the data size of the stored value in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
+ !-----------------------------------------------------------------
+DataSizeInBytes = byte_size_logical(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper4D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper4D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper4D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper4D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx1, idx2, idx3, idx4
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ DO idx1 = 1, SIZE(this%VALUE, 1)
+ String = String//TRIM(str(n=this%VALUE(idx1, idx2, idx3, idx4)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper4D_L_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper4D_L_Print
-end module DimensionsWrapper4D_L
+END MODULE DimensionsWrapper4D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90
index 09e494310..33f145deb 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R4P.F90
@@ -18,232 +18,222 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper4D_R4P
-
+MODULE DimensionsWrapper4D_R4P
USE DimensionsWrapper4D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R4P_t
- real(R4P), allocatable :: Value(:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper4D_R4P_Set
- procedure, public :: Get => DimensionsWrapper4D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper4D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper4D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper4D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper4D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper4D_R4P_toString
- procedure, public :: Free => DimensionsWrapper4D_R4P_Free
- procedure, public :: Print => DimensionsWrapper4D_R4P_Print
- final :: DimensionsWrapper4D_R4P_Final
- end type
-
-public :: DimensionsWrapper4D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper4D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper4D
- !-----------------------------------------------------------------
- type(DimensionsWrapper4D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper4D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper4D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper4D
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper4D_R4P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the data size of the stored value in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this !< Dimensions wrapper 4D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value)
- end function DimensionsWrapper4D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper4D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this !< Dimensions wrapper 4D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper4D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper4D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper4D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper4D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_R4P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_R4P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_R4P_Print
+ FINAL :: DimensionsWrapper4D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper4D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper4D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper4D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper4D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_R4P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the data size of the stored value in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper4D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper4D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper4D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper4D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper4D_R4P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper4D_R4P_Print
-end module DimensionsWrapper4D_R4P
+END MODULE DimensionsWrapper4D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90
index 400397aed..5ef56fa1b 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper4D/DimensionsWrapper4D_R8P.F90
@@ -18,232 +18,222 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper4D_R8P
-
+MODULE DimensionsWrapper4D_R8P
USE DimensionsWrapper4D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R8P_t
- real(R8P), allocatable :: Value(:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper4D_R8P_Set
- procedure, public :: Get => DimensionsWrapper4D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper4D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper4D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper4D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper4D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper4D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper4D_R8P_toString
- procedure, public :: Free => DimensionsWrapper4D_R8P_Free
- procedure, public :: Print => DimensionsWrapper4D_R8P_Print
- final :: DimensionsWrapper4D_R8P_Final
- end type
-
-public :: DimensionsWrapper4D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper4D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper4D
- !-----------------------------------------------------------------
- type(DimensionsWrapper4D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper4D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper4D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper4D
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper4D_R8P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the data size of the stored value in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this !< Dimensions wrapper 4D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1))*size(this%value)
- end function DimensionsWrapper4D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper4D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this !< Dimensions wrapper 4D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper4D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper4D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4))) // Sep
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper4D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper4D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper4D_t) :: DimensionsWrapper4D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper4D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper4D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper4D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper4D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper4D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper4D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper4D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper4D_R8P_toString
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper4D_R8P_Free
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper4D_R8P_Print
+ FINAL :: DimensionsWrapper4D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper4D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper4D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper4D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper4D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper4D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper4D_R8P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the data size of the stored value in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes of the stored value
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper4D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper4D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 4D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper4D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper4D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4)))//Sep
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper4D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper4D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper4D_R8P_Print
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper4D_R8P_Print
-end module DimensionsWrapper4D_R8P
+END MODULE DimensionsWrapper4D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90
index e78e2ed6e..168d20e4c 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I2P.F90
@@ -18,236 +18,225 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper5D_I2P
+MODULE DimensionsWrapper5D_I2P
USE DimensionsWrapper5D
-USE PENF, only: I2P, I4P, str, byte_size
+USE PENF, ONLY: I2P, I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I2P_t
- integer(I2P), allocatable :: Value(:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper5D_I2P_Set
- procedure, public :: Get => DimensionsWrapper5D_I2P_Get
- procedure, public :: GetShape => DimensionsWrapper5D_I2P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper5D_I2P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper5D_I2P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I2P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper5D_I2P_isOfDataType
- procedure, public :: toString => DimensionsWrapper5D_I2P_toString
- procedure, public :: Print => DimensionsWrapper5D_I2P_Print
- procedure, public :: Free => DimensionsWrapper5D_I2P_Free
- final :: DimensionsWrapper5D_I2P_Final
- end type
-
-public :: DimensionsWrapper5D_I2P_t
-
-contains
-
-
- subroutine DimensionsWrapper5D_I2P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper5D
- !-----------------------------------------------------------------
- type(DimensionsWrapper5D_I2P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I2P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I2P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I2P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I2P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I2P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I2P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I2P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I2P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I2P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper5D_I2P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper5D_I2P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I2P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper5D
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper5D_I2P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this !< Dimensions wrapper 5D
- integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper5D_I2P_DataSizeInBytes
-
-
- function DimensionsWrapper5D_I2P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this !< Dimensions wrapper 5D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I2P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper5D_I2P_isOfDataType
-
-
- subroutine DimensionsWrapper5D_I2P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I2P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I2P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I2P_t
+ INTEGER(I2P), ALLOCATABLE :: VALUE(:, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_I2P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_I2P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_I2P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_I2P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_I2P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I2P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_I2P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_I2P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_I2P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_I2P_Free
+ FINAL :: DimensionsWrapper5D_I2P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper5D_I2P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper5D_I2P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper5D_I2P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I2P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I2P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I2P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I2P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I2P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I2P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I2P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_I2P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper5D_I2P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I2P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_I2P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper5D_I2P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper5D_I2P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I2P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper5D_I2P_isOfDataType
+
+SUBROUTINE DimensionsWrapper5D_I2P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I2P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I2P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I2P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper5D_I2P_Print
-
-end module DimensionsWrapper5D_I2P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper5D_I2P_Print
+
+END MODULE DimensionsWrapper5D_I2P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90
index 3fbd5a841..e2aba1e33 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I4P.F90
@@ -18,235 +18,224 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper5D_I4P
+MODULE DimensionsWrapper5D_I4P
USE DimensionsWrapper5D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I4P_t
- integer(I4P), allocatable :: Value(:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper5D_I4P_Set
- procedure, public :: Get => DimensionsWrapper5D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper5D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper5D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper5D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper5D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper5D_I4P_toString
- procedure, public :: Print => DimensionsWrapper5D_I4P_Print
- procedure, public :: Free => DimensionsWrapper5D_I4P_Free
- final :: DimensionsWrapper5D_I4P_Final
- end type
-
-public :: DimensionsWrapper5D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper5D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper5D
- !-----------------------------------------------------------------
- type(DimensionsWrapper5D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5)), &
- source=Value, stat=err)
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper5D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper5D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper5D
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper5D_I4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this !< Dimensions wrapper 5D
- integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper5D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper5D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this !< Dimensions wrapper 5D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper5D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper5D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_I4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_I4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_I4P_Free
+ FINAL :: DimensionsWrapper5D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper5D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper5D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper5D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5)), &
+ source=VALUE, stat=err)
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper5D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper5D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper5D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper5D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper5D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper5D_I4P_Print
-
-end module DimensionsWrapper5D_I4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper5D_I4P_Print
+
+END MODULE DimensionsWrapper5D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90
index af5fc8610..304c74cad 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_I8P.F90
@@ -18,235 +18,225 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper5D_I8P
+MODULE DimensionsWrapper5D_I8P
USE DimensionsWrapper5D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I8P_t
- integer(I8P), allocatable :: Value(:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper5D_I8P_Set
- procedure, public :: Get => DimensionsWrapper5D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper5D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper5D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper5D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper5D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper5D_I8P_toString
- procedure, public :: Print => DimensionsWrapper5D_I8P_Print
- procedure, public :: Free => DimensionsWrapper5D_I8P_Free
- final :: DimensionsWrapper5D_I8P_Final
- end type
-
-public :: DimensionsWrapper5D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper5D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper5D
- !-----------------------------------------------------------------
- type(DimensionsWrapper5D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper5D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
- subroutine DimensionsWrapper5D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper5D
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper5D_I8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this !< Dimensions wrapper 5D
- integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper5D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper5D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this !< Dimensions wrapper 5D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper5D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper5D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper5D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_I8P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_I8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_I8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_I8P_Free
+ FINAL :: DimensionsWrapper5D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper5D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper5D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper5D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper5D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper5D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper5D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper5D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper5D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper5D_I8P_Print
-
-end module DimensionsWrapper5D_I8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper5D_I8P_Print
+
+END MODULE DimensionsWrapper5D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90
index ec5e237e9..02214dca9 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_L.F90
@@ -18,239 +18,229 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper5D_L
+MODULE DimensionsWrapper5D_L
USE DimensionsWrapper5D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_L_t
- logical, allocatable :: Value(:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper5D_L_Set
- procedure, public :: Get => DimensionsWrapper5D_L_Get
- procedure, public :: GetShape => DimensionsWrapper5D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper5D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper5D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper5D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper5D_L_toString
- procedure, public :: Print => DimensionsWrapper5D_L_Print
- procedure, public :: Free => DimensionsWrapper5D_L_Free
- final :: DimensionsWrapper5D_L_Final
- end type
-
-public :: DimensionsWrapper5D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper5D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper5D
- !-----------------------------------------------------------------
- type(DimensionsWrapper5D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper5D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper5D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper5D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper5D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper5D
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper5D_L_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this !< Dimensions wrapper 5D
- integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper5D_L_DataSizeInBytes
-
-
- function DimensionsWrapper5D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this !< Dimensions wrapper 5D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper5D_L_isOfDataType
-
-
- subroutine DimensionsWrapper5D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx1,idx2,idx3,idx4,idx5
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- do idx1=1, size(this%Value,1)
- String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4,idx5))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper5D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper5D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper5D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_L_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_L_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_L_Free
+ FINAL :: DimensionsWrapper5D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper5D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper5D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper5D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper5D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper5D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper5D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper5D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper5D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx1, idx2, idx3, idx4, idx5
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ DO idx1 = 1, SIZE(this%VALUE, 1)
+ String = String//TRIM(str(n=this%VALUE(idx1, idx2, idx3, idx4, idx5)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper5D_L_Print
-
-end module DimensionsWrapper5D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper5D_L_Print
+
+END MODULE DimensionsWrapper5D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90
index b340628f6..d3c382bab 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R4P.F90
@@ -18,236 +18,227 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper5D_R4P
+MODULE DimensionsWrapper5D_R4P
USE DimensionsWrapper5D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R4P_t
- real(R4P), allocatable :: Value(:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper5D_R4P_Set
- procedure, public :: Get => DimensionsWrapper5D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper5D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper5D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper5D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper5D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper5D_R4P_toString
- procedure, public :: Print => DimensionsWrapper5D_R4P_Print
- procedure, public :: Free => DimensionsWrapper5D_R4P_Free
- final :: DimensionsWrapper5D_R4P_Final
- end type
-
-public :: DimensionsWrapper5D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper5D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper5D
- !-----------------------------------------------------------------
- type(DimensionsWrapper5D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper5D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper5D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper5D
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper5D_R4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this !< Dimensions wrapper 5D
- integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper5D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper5D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this !< Dimensions wrapper 5D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper5D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper5D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper5D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper5D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_R4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_R4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_R4P_Free
+ FINAL :: DimensionsWrapper5D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper5D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper5D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper5D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper5D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper5D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper5D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper5D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper5D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper5D_R4P_Print
-
-end module DimensionsWrapper5D_R4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper5D_R4P_Print
+
+END MODULE DimensionsWrapper5D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90
index 3521ff661..99d50db80 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper5D/DimensionsWrapper5D_R8P.F90
@@ -18,236 +18,226 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper5D_R8P
-
+MODULE DimensionsWrapper5D_R8P
USE DimensionsWrapper5D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R8P_t
- real(R8P), allocatable :: Value(:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper5D_R8P_Set
- procedure, public :: Get => DimensionsWrapper5D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper5D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper5D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper5D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper5D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper5D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper5D_R8P_toString
- procedure, public :: Print => DimensionsWrapper5D_R8P_Print
- procedure, public :: Free => DimensionsWrapper5D_R8P_Free
- final :: DimensionsWrapper5D_R8P_Final
- end type
-
-public :: DimensionsWrapper5D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper5D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper5D
- !-----------------------------------------------------------------
- type(DimensionsWrapper5D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper5D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper5D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper5D
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper5D_R8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this !< Dimensions wrapper 5D
- integer(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper5D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper5D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this !< Dimensions wrapper 5D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper5D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper5D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5))) // Sep
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper5D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper5D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper5D_t) :: DimensionsWrapper5D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper5D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper5D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper5D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper5D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper5D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper5D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper5D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper5D_R8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper5D_R8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper5D_R8P_Free
+ FINAL :: DimensionsWrapper5D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper5D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper5D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper5D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper5D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper5D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper5D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of lthe stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper5D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper5D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 5D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper5D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper5D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper5D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper5D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper5D_R8P_Print
-
-end module DimensionsWrapper5D_R8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper5D_R8P_Print
+
+END MODULE DimensionsWrapper5D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90
index 7d1841fdc..a14549ddc 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I2P.F90
@@ -18,240 +18,229 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper6D_I2P
+MODULE DimensionsWrapper6D_I2P
USE DimensionsWrapper6D
-USE PENF, only: I2P, I4P, str, byte_size
+USE PENF, ONLY: I2P, I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I2P_t
- integer(I2P), allocatable :: Value(:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper6D_I2P_Set
- procedure, public :: Get => DimensionsWrapper6D_I2P_Get
- procedure, public :: GetShape => DimensionsWrapper6D_I2P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper6D_I2P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper6D_I2P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I2P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper6D_I2P_isOfDataType
- procedure, public :: toString => DimensionsWrapper6D_I2P_toString
- procedure, public :: Print => DimensionsWrapper6D_I2P_Print
- procedure, public :: Free => DimensionsWrapper6D_I2P_Free
- final :: DimensionsWrapper6D_I2P_Final
- end type
-
-public :: DimensionsWrapper6D_I2P_t
-
-contains
-
-
- subroutine DimensionsWrapper6D_I2P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper6D
- !-----------------------------------------------------------------
- type(DimensionsWrapper6D_I2P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I2P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I2P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I2P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I2P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I2P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I2P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I2P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I2P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I2P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper6D_I2P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper6D_I2P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I2P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper6D
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper6D_I2P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this !< Dimensions wrapper 6D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper6D_I2P_DataSizeInBytes
-
-
- function DimensionsWrapper6D_I2P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this !< Dimensions wrapper 6D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I2P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper6D_I2P_isOfDataType
-
-
- subroutine DimensionsWrapper6D_I2P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I2P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I2P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I2P_t
+ INTEGER(I2P), ALLOCATABLE :: VALUE(:, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_I2P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_I2P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_I2P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_I2P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_I2P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I2P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_I2P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_I2P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_I2P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_I2P_Free
+ FINAL :: DimensionsWrapper6D_I2P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper6D_I2P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper6D_I2P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper6D_I2P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I2P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I2P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I2P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I2P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I2P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I2P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I2P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_I2P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper6D_I2P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I2P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_I2P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper6D_I2P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper6D_I2P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I2P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper6D_I2P_isOfDataType
+
+SUBROUTINE DimensionsWrapper6D_I2P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I2P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I2P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I2P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper6D_I2P_Print
-
-end module DimensionsWrapper6D_I2P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper6D_I2P_Print
+
+END MODULE DimensionsWrapper6D_I2P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90
index c91f3141b..83de84e21 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I4P.F90
@@ -18,240 +18,229 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper6D_I4P
+MODULE DimensionsWrapper6D_I4P
USE DimensionsWrapper6D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I4P_t
- integer(I4P), allocatable :: Value(:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper6D_I4P_Set
- procedure, public :: Get => DimensionsWrapper6D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper6D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper6D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper6D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper6D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper6D_I4P_toString
- procedure, public :: Print => DimensionsWrapper6D_I4P_Print
- procedure, public :: Free => DimensionsWrapper6D_I4P_Free
- final :: DimensionsWrapper6D_I4P_Final
- end type
-
-public :: DimensionsWrapper6D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper6D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper6D
- !-----------------------------------------------------------------
- type(DimensionsWrapper6D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper6D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper6D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper6D
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper6D_I4P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this !< Dimensions wrapper 6D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper6D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper6D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this !< Dimensions wrapper 6D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper6D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper6D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_I4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_I4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_I4P_Free
+ FINAL :: DimensionsWrapper6D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper6D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper6D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper6D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper6D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_I4P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper6D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper6D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper6D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper6D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper6D_I4P_Print
-
-end module DimensionsWrapper6D_I4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper6D_I4P_Print
+
+END MODULE DimensionsWrapper6D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90
index 754a73cdc..2709bdb84 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_I8P.F90
@@ -18,241 +18,229 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper6D_I8P
+MODULE DimensionsWrapper6D_I8P
USE DimensionsWrapper6D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-
-implicit none
-private
-
- type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I8P_t
- integer(I8P), allocatable :: Value(:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper6D_I8P_Set
- procedure, public :: Get => DimensionsWrapper6D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper6D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper6D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper6D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper6D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper6D_I8P_toString
- procedure, public :: Print => DimensionsWrapper6D_I8P_Print
- procedure, public :: Free => DimensionsWrapper6D_I8P_Free
- final :: DimensionsWrapper6D_I8P_Final
- end type
-
-public :: DimensionsWrapper6D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper6D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper6D
- !-----------------------------------------------------------------
- type(DimensionsWrapper6D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper6D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper6D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper6D
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper6D_I8P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this !< Dimensions wrapper 6D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper6D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper6D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this !< Dimensions wrapper 6D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper6D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper6D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper6D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_I8P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_I8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_I8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_I8P_Free
+ FINAL :: DimensionsWrapper6D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper6D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper6D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper6D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper6D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_I8P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper6D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper6D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper6D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper6D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper6D_I8P_Print
-
-end module DimensionsWrapper6D_I8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper6D_I8P_Print
+
+END MODULE DimensionsWrapper6D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90
index 657218d52..2e8c0a1b8 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_L.F90
@@ -18,243 +18,233 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper6D_L
+MODULE DimensionsWrapper6D_L
USE DimensionsWrapper6D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_L_t
- logical, allocatable :: Value(:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper6D_L_Set
- procedure, public :: Get => DimensionsWrapper6D_L_Get
- procedure, public :: GetShape => DimensionsWrapper6D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper6D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper6D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper6D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper6D_L_toString
- procedure, public :: Print => DimensionsWrapper6D_L_Print
- procedure, public :: Free => DimensionsWrapper6D_L_Free
- final :: DimensionsWrapper6D_L_Final
- end type
-
-public :: DimensionsWrapper6D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper6D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper6D
- !-----------------------------------------------------------------
- type(DimensionsWrapper6D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper6D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper6D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper6D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper6D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper6D
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper6D_L_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this !< Dimensions wrapper 6D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper6D_L_DataSizeInBytes
-
-
- function DimensionsWrapper6D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this !< Dimensions wrapper 6D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper6D_L_isOfDataType
-
-
- subroutine DimensionsWrapper6D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx1,idx2,idx3,idx4,idx5,idx6
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- do idx1=1, size(this%Value,1)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper6D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper6D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_L_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_L_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_L_Free
+ FINAL :: DimensionsWrapper6D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper6D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper6D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper6D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper6D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_L_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper6D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper6D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper6D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper6D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx1, idx2, idx3, idx4, idx5, idx6
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ DO idx1 = 1, SIZE(this%VALUE, 1)
String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4,idx5,idx6))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper6D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper6D_L_Print
-
-end module DimensionsWrapper6D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper6D_L_Print
+
+END MODULE DimensionsWrapper6D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90
index c5f84b200..66fb52d5f 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R4P.F90
@@ -18,240 +18,230 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper6D_R4P
-
+MODULE DimensionsWrapper6D_R4P
USE DimensionsWrapper6D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R4P_t
- real(R4P), allocatable :: Value(:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper6D_R4P_Set
- procedure, public :: Get => DimensionsWrapper6D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper6D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper6D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper6D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper6D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper6D_R4P_toString
- procedure, public :: Print => DimensionsWrapper6D_R4P_Print
- procedure, public :: Free => DimensionsWrapper6D_R4P_Free
- final :: DimensionsWrapper6D_R4P_Final
- end type
-
-public :: DimensionsWrapper6D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper6D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper6D
- !-----------------------------------------------------------------
- type(DimensionsWrapper6D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper6D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper6D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper6D
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper6D_R4P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this !< Dimensions wrapper 6D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper6D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper6D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this !< Dimensions wrapper 6D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper6D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper6D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper6D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper6D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_R4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_R4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_R4P_Free
+ FINAL :: DimensionsWrapper6D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper6D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper6D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper6D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper6D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_R4P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper6D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper6D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper6D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper6D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper6D_R4P_Print
-
-end module DimensionsWrapper6D_R4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper6D_R4P_Print
+
+END MODULE DimensionsWrapper6D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90
index a9864c4a6..82c0130fe 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper6D/DimensionsWrapper6D_R8P.F90
@@ -18,240 +18,230 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper6D_R8P
-
+MODULE DimensionsWrapper6D_R8P
USE DimensionsWrapper6D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R8P_t
- real(R8P), allocatable :: Value(:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper6D_R8P_Set
- procedure, public :: Get => DimensionsWrapper6D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper6D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper6D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper6D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper6D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper6D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper6D_R8P_toString
- procedure, public :: Print => DimensionsWrapper6D_R8P_Print
- procedure, public :: Free => DimensionsWrapper6D_R8P_Free
- final :: DimensionsWrapper6D_R8P_Final
- end type
-
-public :: DimensionsWrapper6D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper6D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper6D
- !-----------------------------------------------------------------
- type(DimensionsWrapper6D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
-
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper6D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper6D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper6D
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper6D_R8P_DataSizeInBytes(this) result(DatasizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the stored data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this !< Dimensions wrapper 6D
- integer(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper6D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper6D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this !< Dimensions wrapper 6D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper6D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper6D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper6D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper6D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper6D_t) :: DimensionsWrapper6D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper6D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper6D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper6D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper6D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper6D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper6D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper6D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper6D_R8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper6D_R8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper6D_R8P_Free
+ FINAL :: DimensionsWrapper6D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper6D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper6D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper6D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper6D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper6D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper6D_R8P_DataSizeInBytes(this) RESULT(DatasizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the stored data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ INTEGER(I4P) :: DataSizeInBytes !< Size of the stored data in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%VALUE(1, 1, 1, 1, 1, 1)) * SIZE(this%VALUE)
+END FUNCTION DimensionsWrapper6D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper6D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 6D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper6D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper6D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+String = String//TRIM(str(n=this%VALUE(:, idx2, idx3, idx4, idx5, idx6)))//Sep
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper6D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper6D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper6D_R8P_Print
-
-end module DimensionsWrapper6D_R8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper6D_R8P_Print
+
+END MODULE DimensionsWrapper6D_R8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90
index 1f1bf25f4..366c8a297 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D.F90
@@ -1,6 +1,6 @@
!-----------------------------------------------------------------
! FPL (Fortran Parameter List)
-! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
+! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
! Javier Principe and VÃctor Sande.
! All rights reserved.
!
@@ -18,47 +18,47 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D
+MODULE DimensionsWrapper7D
USE DimensionsWrapper
-implicit none
-private
+IMPLICIT NONE
+PRIVATE
- type, extends(DimensionsWrapper_t), abstract :: DimensionsWrapper7D_t
- private
- contains
- procedure(DimensionsWrapper7D_Set), deferred :: Set
- procedure(DimensionsWrapper7D_Get), deferred :: Get
- procedure(DimensionsWrapper7D_GetPointer), deferred :: GetPointer
- end type
+TYPE, EXTENDS(DimensionsWrapper_t), ABSTRACT :: DimensionsWrapper7D_t
+ PRIVATE
+CONTAINS
+ PROCEDURE(DimensionsWrapper7D_Set), DEFERRED :: Set
+ PROCEDURE(DimensionsWrapper7D_Get), DEFERRED :: Get
+ PROCEDURE(DimensionsWrapper7D_GetPointer), DEFERRED :: GetPointer
+END TYPE
- abstract interface
- subroutine DimensionsWrapper7D_Set(this, Value)
- import DimensionsWrapper7D_t
- class(DimensionsWrapper7D_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- end subroutine
+ABSTRACT INTERFACE
+ SUBROUTINE DimensionsWrapper7D_Set(this, VALUE)
+ IMPORT DimensionsWrapper7D_t
+ CLASS(DimensionsWrapper7D_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ END SUBROUTINE
- subroutine DimensionsWrapper7D_Get(this, Value)
- import DimensionsWrapper7D_t
- class(DimensionsWrapper7D_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- end subroutine
+ SUBROUTINE DimensionsWrapper7D_Get(this, VALUE)
+ IMPORT DimensionsWrapper7D_t
+ CLASS(DimensionsWrapper7D_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ END SUBROUTINE
- function DimensionsWrapper7D_GetPointer(this) result(Value)
- import DimensionsWrapper7D_t
- class(DimensionsWrapper7D_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- end function
+ FUNCTION DimensionsWrapper7D_GetPointer(this) RESULT(VALUE)
+ IMPORT DimensionsWrapper7D_t
+ CLASS(DimensionsWrapper7D_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ END FUNCTION
- subroutine DimensionsWrapper7D_GetPolymorphic(this, Value)
- import DimensionsWrapper7D_t
- class(DimensionsWrapper7D_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- end subroutine
- end interface
+ SUBROUTINE DimensionsWrapper7D_GetPolymorphic(this, VALUE)
+ IMPORT DimensionsWrapper7D_t
+ CLASS(DimensionsWrapper7D_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ END SUBROUTINE
+END INTERFACE
-public :: DimensionsWrapper7D_t
+PUBLIC :: DimensionsWrapper7D_t
-end module DimensionsWrapper7D
+END MODULE DimensionsWrapper7D
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90
index b86dc8c82..389cdf214 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I2P.F90
@@ -18,243 +18,232 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D_I2P
+MODULE DimensionsWrapper7D_I2P
USE DimensionsWrapper7D
-USE PENF, only: I2P, I4P, str, byte_size
+USE PENF, ONLY: I2P, I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I2P_t
- integer(I2P), allocatable :: Value(:,:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper7D_I2P_Set
- procedure, public :: Get => DimensionsWrapper7D_I2P_Get
- procedure, public :: GetShape => DimensionsWrapper7D_I2P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper7D_I2P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper7D_I2P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I2P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper7D_I2P_isOfDataType
- procedure, public :: toString => DimensionsWrapper7D_I2P_toString
- procedure, public :: Print => DimensionsWrapper7D_I2P_Print
- procedure, public :: Free => DimensionsWrapper7D_I2P_Free
- final :: DimensionsWrapper7D_I2P_Final
- end type
-
-public :: DimensionsWrapper7D_I2P_t
-
-contains
-
-
- subroutine DimensionsWrapper7D_I2P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper7D
- !-----------------------------------------------------------------
- type(DimensionsWrapper7D_I2P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I2P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I2P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I2P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6), &
- size(Value,dim=7)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I2P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I2P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I2P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I2P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I2P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I2P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper7D_I2P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper7D_I2P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6), &
- size(this%Value,dim=7)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I2P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper7D
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper7D_i2p_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_i2p_t), intent(IN) :: this !< Dimensions wrapper 7D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper7D_i2p_DataSizeInBytes
-
-
- function DimensionsWrapper7D_I2P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(IN) :: this !< Dimensions wrapper 7D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I2P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper7D_I2P_isOfDataType
-
-
- subroutine DimensionsWrapper7D_I2P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx7=1, size(this%Value,7)
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I2P_t
+ INTEGER(I2P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_I2P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_I2P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_I2P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_I2P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper7D_I2P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I2P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_I2P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_I2P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_I2P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_I2P_Free
+ FINAL :: DimensionsWrapper7D_I2P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper7D_I2P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper7D_I2P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper7D_I2P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I2P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I2P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6), &
+ SIZE(VALUE, dim=7)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I2P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I2P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I2P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I2P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I2P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_I2P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper7D_I2P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6), &
+ SIZE(this%VALUE, dim=7)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I2P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_i2p_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_i2p_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper7D_i2p_DataSizeInBytes
+
+FUNCTION DimensionsWrapper7D_I2P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I2P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper7D_I2P_isOfDataType
+
+SUBROUTINE DimensionsWrapper7D_I2P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx7 = 1, SIZE(this%VALUE, 7)
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I2P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I2P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I2P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I2P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I2P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper7D_I2P_Print
-
-end module DimensionsWrapper7D_I2P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper7D_I2P_Print
+
+END MODULE DimensionsWrapper7D_I2P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90
index 32f371693..bc8427e96 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I4P.F90
@@ -18,243 +18,232 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D_I4P
+MODULE DimensionsWrapper7D_I4P
USE DimensionsWrapper7D
-USE PENF, only: I4P, str, byte_size
+USE PENF, ONLY: I4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I4P_t
- integer(I4P), allocatable :: Value(:,:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper7D_I4P_Set
- procedure, public :: Get => DimensionsWrapper7D_I4P_Get
- procedure, public :: GetShape => DimensionsWrapper7D_I4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper7D_I4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper7D_I4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper7D_I4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper7D_I4P_toString
- procedure, public :: Print => DimensionsWrapper7D_I4P_Print
- procedure, public :: Free => DimensionsWrapper7D_I4P_Free
- final :: DimensionsWrapper7D_I4P_Final
- end type
-
-public :: DimensionsWrapper7D_I4P_t
-
-contains
-
-
- subroutine DimensionsWrapper7D_I4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper7D
- !-----------------------------------------------------------------
- type(DimensionsWrapper7D_I4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6), &
- size(Value,dim=7)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper7D_I4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper7D_I4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6), &
- size(this%Value,dim=7)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper7D
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper7D_I4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this !< Dimensions wrapper 7D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper7D_I4P_DataSizeInBytes
-
-
- function DimensionsWrapper7D_I4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this !< Dimensions wrapper 7D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper7D_I4P_isOfDataType
-
-
- subroutine DimensionsWrapper7D_I4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx7=1, size(this%Value,7)
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I4P_t
+ INTEGER(I4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_I4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_I4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_I4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_I4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper7D_I4P_GetPolymorphic
+procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_I4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_I4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_I4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_I4P_Free
+ FINAL :: DimensionsWrapper7D_I4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper7D_I4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper7D_I4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper7D_I4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6), &
+ SIZE(VALUE, dim=7)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_I4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper7D_I4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6), &
+ SIZE(this%VALUE, dim=7)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_I4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper7D_I4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper7D_I4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper7D_I4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper7D_I4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx7 = 1, SIZE(this%VALUE, 7)
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper7D_I4P_Print
-
-end module DimensionsWrapper7D_I4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper7D_I4P_Print
+
+END MODULE DimensionsWrapper7D_I4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90
index a6cbcaa18..90caf57f2 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_I8P.F90
@@ -18,243 +18,234 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D_I8P
+MODULE DimensionsWrapper7D_I8P
USE DimensionsWrapper7D
-USE PENF, only: I4P, I8P, str, byte_size
+USE PENF, ONLY: I4P, I8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I8P_t
- integer(I8P), allocatable :: Value(:,:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper7D_I8P_Set
- procedure, public :: Get => DimensionsWrapper7D_I8P_Get
- procedure, public :: GetShape => DimensionsWrapper7D_I8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper7D_I8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper7D_I8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_I8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper7D_I8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper7D_I8P_toString
- procedure, public :: Print => DimensionsWrapper7D_I8P_Print
- procedure, public :: Free => DimensionsWrapper7D_I8P_Free
- final :: DimensionsWrapper7D_I8P_Final
- end type
-
-public :: DimensionsWrapper7D_I8P_t
-
-contains
-
-
- subroutine DimensionsWrapper7D_I8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper7D
- !-----------------------------------------------------------------
- type(DimensionsWrapper7D_I8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6), &
- size(Value,dim=7)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (I8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get I8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (integer(I8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (I8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper7D_I8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper7D_I8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6), &
- size(this%Value,dim=7)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper7D
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper7D_I8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this !< Dimensions wrapper 7D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper7D_I8P_DataSizeInBytes
-
-
- function DimensionsWrapper7D_I8P_isOfDataType(this, Mold) result(isOfDataType)
- !---------------------------------------- procedure, public :: toString => DimensionsWrapper7D_R8P_toString-------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this !< Dimensions wrapper 7D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (integer(I8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper7D_I8P_isOfDataType
-
-
- subroutine DimensionsWrapper7D_I8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx7=1, size(this%Value,7)
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_I8P_t
+ INTEGER(I8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_I8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_I8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_I8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_I8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper7D_I8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper7D_I8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_I8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_I8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_I8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_I8P_Free
+ FINAL :: DimensionsWrapper7D_I8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper7D_I8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper7D_I8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper7D_I8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6), &
+ SIZE(VALUE, dim=7)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get I8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (I8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_I8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper7D_I8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6), &
+ SIZE(this%VALUE, dim=7)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_I8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper7D_I8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper7D_I8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !---------------------------------------- procedure, public :: toString => DimensionsWrapper7D_R8P_toString-------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (INTEGER(I8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper7D_I8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper7D_I8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx7 = 1, SIZE(this%VALUE, 7)
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper7D_I8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_I8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_I8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_I8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = I8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper7D_I8P_Print
-
-end module DimensionsWrapper7D_I8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper7D_I8P_Print
+
+END MODULE DimensionsWrapper7D_I8P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90
index 08dc231a5..78da6401c 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_L.F90
@@ -18,245 +18,235 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D_L
-
+MODULE DimensionsWrapper7D_L
USE DimensionsWrapper7D
USE FPL_Utils
-USE PENF, only: I4P, str
+USE PENF, ONLY: I4P, str
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_L_t
- logical, allocatable :: Value(:,:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper7D_L_Set
- procedure, public :: Get => DimensionsWrapper7D_L_Get
- procedure, public :: GetShape => DimensionsWrapper7D_L_GetShape
- procedure, public :: GetPointer => DimensionsWrapper7D_L_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper7D_L_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_L_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper7D_L_isOfDataType
- procedure, public :: toString => DimensionsWrapper7D_L_toString
- procedure, public :: Print => DimensionsWrapper7D_L_Print
- procedure, public :: Free => DimensionsWrapper7D_L_Free
- final :: DimensionsWrapper7D_L_Final
- end type
-
-public :: DimensionsWrapper7D_L_t
-
-contains
-
-
- subroutine DimensionsWrapper7D_L_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper7D
- !-----------------------------------------------------------------
- type(DimensionsWrapper7D_L_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper7D_L_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6), &
- size(Value,dim=7)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (logical)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_L_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get logical Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (logical)
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (L)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_L_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
- function DimensionsWrapper7D_L_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper7D_L_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6), &
- size(this%Value,dim=7)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper7D_L_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper7D
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper7D_L_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this !< Dimensions wrapper 7D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes
- !-----------------------------------------------------------------
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_L_t
+ LOGICAL, ALLOCATABLE :: VALUE(:, :, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_L_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_L_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_L_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_L_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => DimensionsWrapper7D_L_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper7D_L_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_L_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_L_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_L_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_L_Free
+ FINAL :: DimensionsWrapper7D_L_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper7D_L_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper7D_L_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper7D_L_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_L_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6), &
+ SIZE(VALUE, dim=7)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (logical)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_L_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get logical Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (LOGICAL)
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (L)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_L_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_L_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper7D_L_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6), &
+ SIZE(this%VALUE, dim=7)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_L_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_L_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes
+ !-----------------------------------------------------------------
DataSizeInBytes = byte_size_logical(this%value(1,1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper7D_L_DataSizeInBytes
-
-
- function DimensionsWrapper7D_L_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this !< Dimensions wrapper 7D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (logical)
- isOfDataType = .true.
- end select
- end function DimensionsWrapper7D_L_isOfDataType
-
-
- subroutine DimensionsWrapper7D_L_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx1,idx2,idx3,idx4,idx5,idx6,idx7
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx7=1, size(this%Value,7)
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
- do idx1=1, size(this%Value,1)
+END FUNCTION DimensionsWrapper7D_L_DataSizeInBytes
+
+FUNCTION DimensionsWrapper7D_L_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (LOGICAL)
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper7D_L_isOfDataType
+
+SUBROUTINE DimensionsWrapper7D_L_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx1, idx2, idx3, idx4, idx5, idx6, idx7
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx7 = 1, SIZE(this%VALUE, 7)
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
+ DO idx1 = 1, SIZE(this%VALUE, 1)
String = String // trim(str(n=this%Value(idx1,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper7D_L_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_L_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_L_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_L_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = L'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper7D_L_Print
-
-end module DimensionsWrapper7D_L
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper7D_L_Print
+
+END MODULE DimensionsWrapper7D_L
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90
index cbd5cc5a9..090b3e31f 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R4P.F90
@@ -18,243 +18,234 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D_R4P
+MODULE DimensionsWrapper7D_R4P
USE DimensionsWrapper7D
-USE PENF, only: I4P, R4P, str, byte_size
+USE PENF, ONLY: I4P, R4P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R4P_t
- real(R4P), allocatable :: Value(:,:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper7D_R4P_Set
- procedure, public :: Get => DimensionsWrapper7D_R4P_Get
- procedure, public :: GetShape => DimensionsWrapper7D_R4P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper7D_R4P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper7D_R4P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_R4P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper7D_R4P_isOfDataType
- procedure, public :: toString => DimensionsWrapper7D_R4P_toString
- procedure, public :: Print => DimensionsWrapper7D_R4P_Print
- procedure, public :: Free => DimensionsWrapper7D_R4P_Free
- final :: DimensionsWrapper7D_R4P_Final
- end type
-
-public :: DimensionsWrapper7D_R4P_t
-
-contains
-
-
- subroutine DimensionsWrapper7D_R4P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper7D
- !-----------------------------------------------------------------
- type(DimensionsWrapper7D_R4P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R4P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6), &
- size(Value,dim=7)), &
- stat=err)
- this%Value = Value
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R4P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R4P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R4P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R4P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R4P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R4P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper7D_R4P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper7D_R4P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6), &
- size(this%Value,dim=7)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R4P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper7D
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper7D_R4P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this !< Dimensions wrapper 7D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper7D_R4P_DataSizeInBytes
-
-
- function DimensionsWrapper7D_R4P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this !< Dimensions wrapper 7D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R4P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper7D_R4P_isOfDataType
-
-
- subroutine DimensionsWrapper7D_R4P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx7=1, size(this%Value,7)
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R4P_t
+ REAL(R4P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_R4P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_R4P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_R4P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_R4P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper7D_R4P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper7D_R4P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_R4P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_R4P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_R4P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_R4P_Free
+ FINAL :: DimensionsWrapper7D_R4P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper7D_R4P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper7D_R4P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper7D_R4P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R4P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6), &
+ SIZE(VALUE, dim=7)), &
+ stat=err)
+ this%VALUE = VALUE
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R4P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R4P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R4P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R4P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_R4P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper7D_R4P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6), &
+ SIZE(this%VALUE, dim=7)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R4P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_R4P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper7D_R4P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper7D_R4P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R4P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper7D_R4P_isOfDataType
+
+SUBROUTINE DimensionsWrapper7D_R4P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx7 = 1, SIZE(this%VALUE, 7)
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R4P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R4P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R4P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R4P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R4P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper7D_R4P_Print
-
-end module DimensionsWrapper7D_R4P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper7D_R4P_Print
+
+END MODULE DimensionsWrapper7D_R4P
diff --git a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90 b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90
index 90c0581ad..2f05ffbb0 100644
--- a/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90
+++ b/src/modules/FPL/src/Wrapper/DimensionsWrapper7D/DimensionsWrapper7D_R8P.F90
@@ -18,242 +18,232 @@
! License along with this library.
!-----------------------------------------------------------------
-module DimensionsWrapper7D_R8P
-
+MODULE DimensionsWrapper7D_R8P
USE DimensionsWrapper7D
-USE PENF, only: I4P, R8P, str, byte_size
+USE PENF, ONLY: I4P, R8P, str, byte_size
USE ErrorMessages
-implicit none
-private
-
- type, extends(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R8P_t
- real(R8P), allocatable :: Value(:,:,:,:,:,:,:)
- contains
- private
- procedure, public :: Set => DimensionsWrapper7D_R8P_Set
- procedure, public :: Get => DimensionsWrapper7D_R8P_Get
- procedure, public :: GetShape => DimensionsWrapper7D_R8P_GetShape
- procedure, public :: GetPointer => DimensionsWrapper7D_R8P_GetPointer
- procedure, public :: GetPolymorphic => DimensionsWrapper7D_R8P_GetPolymorphic
- procedure, public :: DataSizeInBytes=> DimensionsWrapper7D_R8P_DataSizeInBytes
- procedure, public :: isOfDataType => DimensionsWrapper7D_R8P_isOfDataType
- procedure, public :: toString => DimensionsWrapper7D_R8P_toString
- procedure, public :: Print => DimensionsWrapper7D_R8P_Print
- procedure, public :: Free => DimensionsWrapper7D_R8P_Free
- final :: DimensionsWrapper7D_R8P_Final
- end type
-
-public :: DimensionsWrapper7D_R8P_t
-
-contains
-
-
- subroutine DimensionsWrapper7D_R8P_Final(this)
- !-----------------------------------------------------------------
- !< Final procedure of DimensionsWrapper7D
- !-----------------------------------------------------------------
- type(DimensionsWrapper7D_R8P_t), intent(INOUT) :: this
- !-----------------------------------------------------------------
- call this%Free()
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R8P_Set(this, Value)
- !-----------------------------------------------------------------
- !< Set R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(INOUT) :: this
- class(*), intent(IN) :: Value(:,:,:,:,:,:,:)
- integer :: err
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- allocate(this%Value(size(Value,dim=1), &
- size(Value,dim=2), &
- size(Value,dim=3), &
- size(Value,dim=4), &
- size(Value,dim=5), &
- size(Value,dim=6), &
- size(Value,dim=7)), &
- source=Value, stat=err)
- if(err/=0) &
- call msg%Error( txt='Setting Value: Allocation error ('//&
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- class Default
- call msg%Warn( txt='Setting value: Expected data type (R8P)', &
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R8P_Get(this, Value)
- !-----------------------------------------------------------------
- !< Get R8P Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this
- class(*), intent(OUT) :: Value(:,:,:,:,:,:,:)
- integer(I4P), allocatable :: ValueShape(:)
- !-----------------------------------------------------------------
- select type (Value)
- type is (real(R8P))
- call this%GetShape(ValueShape)
- if(all(ValueShape == shape(Value))) then
- Value = this%Value
- else
- call msg%Warn(txt='Getting value: Wrong shape ('//&
- str(no_sign=.true.,n=ValueShape)//'/='//&
- str(no_sign=.true.,n=shape(Value))//')',&
- file=__FILE__, line=__LINE__ )
- endif
- class Default
- call msg%Warn(txt='Getting value: Expected data type (R8P)',&
- file=__FILE__, line=__LINE__ )
- end select
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R8P_GetShape(this, ValueShape)
- !-----------------------------------------------------------------
- !< Get Wrapper Value Shape
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this
- integer(I4P), allocatable, intent(INOUT) :: ValueShape(:)
- !-----------------------------------------------------------------
- if(allocated(ValueShape)) deallocate(ValueShape)
- allocate(ValueShape(this%GetDimensions()))
- ValueShape = shape(this%Value, kind=I4P)
- end subroutine
-
-
- function DimensionsWrapper7D_R8P_GetPointer(this) result(Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic pointer to Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), target, intent(IN) :: this
- class(*), pointer :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- Value => this%Value
- end function
-
-
- subroutine DimensionsWrapper7D_R8P_GetPolymorphic(this, Value)
- !-----------------------------------------------------------------
- !< Get Unlimited Polymorphic Wrapper Value
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this
- class(*), allocatable, intent(OUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- allocate(Value(size(this%Value,dim=1), &
- size(this%Value,dim=2), &
- size(this%Value,dim=3), &
- size(this%Value,dim=4), &
- size(this%Value,dim=5), &
- size(this%Value,dim=6), &
- size(this%Value,dim=7)), &
- source=this%Value)
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R8P_Free(this)
- !-----------------------------------------------------------------
- !< Free a DimensionsWrapper7D
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(INOUT) :: this
- integer :: err
- !-----------------------------------------------------------------
- if(allocated(this%Value)) then
- deallocate(this%Value, stat=err)
- if(err/=0) call msg%Error(txt='Freeing Value: Deallocation error ('// &
- str(no_sign=.true.,n=err)//')', &
- file=__FILE__, line=__LINE__ )
- endif
- end subroutine
-
-
- function DimensionsWrapper7D_R8P_DataSizeInBytes(this) result(DataSizeInBytes)
- !-----------------------------------------------------------------
- !< Return the size of the data in bytes
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this !< Dimensions wrapper 7D
- integer(I4P) :: DataSizeInBytes !< Data size in bytes
- !-----------------------------------------------------------------
- DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
- end function DimensionsWrapper7D_R8P_DataSizeInBytes
-
-
- function DimensionsWrapper7D_R8P_isOfDataType(this, Mold) result(isOfDataType)
- !-----------------------------------------------------------------
- !< Check if Mold and Value are of the same datatype
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this !< Dimensions wrapper 7D
- class(*), intent(IN) :: Mold !< Mold for data type comparison
- logical :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
- !-----------------------------------------------------------------
- isOfDataType = .false.
- select type (Mold)
- type is (real(R8P))
- isOfDataType = .true.
- end select
- end function DimensionsWrapper7D_R8P_isOfDataType
-
-
- subroutine DimensionsWrapper7D_R8P_toString(this, String, Separator)
- !-----------------------------------------------------------------
- !< Return the wrapper value as a string
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this
- character(len=:), allocatable, intent(INOUT) :: String
- character(len=1), optional, intent(IN) :: Separator
- character(len=1) :: Sep
- integer(I4P) :: idx2,idx3,idx4,idx5,idx6,idx7
- !-----------------------------------------------------------------
- String = ''
- Sep = ','
- if(allocated(this%Value)) then
- if(present(Separator)) Sep = Separator
- do idx7=1, size(this%Value,7)
- do idx6=1, size(this%Value,6)
- do idx5=1, size(this%Value,5)
- do idx4=1, size(this%Value,4)
- do idx3=1, size(this%Value,3)
- do idx2=1, size(this%Value,2)
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(DimensionsWrapper7D_t) :: DimensionsWrapper7D_R8P_t
+ REAL(R8P), ALLOCATABLE :: VALUE(:, :, :, :, :, :, :)
+CONTAINS
+ PRIVATE
+ PROCEDURE, PUBLIC :: Set => DimensionsWrapper7D_R8P_Set
+ PROCEDURE, PUBLIC :: Get => DimensionsWrapper7D_R8P_Get
+ PROCEDURE, PUBLIC :: GetShape => DimensionsWrapper7D_R8P_GetShape
+ PROCEDURE, PUBLIC :: GetPointer => DimensionsWrapper7D_R8P_GetPointer
+ PROCEDURE, PUBLIC :: GetPolymorphic => &
+ DimensionsWrapper7D_R8P_GetPolymorphic
+ PROCEDURE, PUBLIC :: DataSizeInBytes => &
+ DimensionsWrapper7D_R8P_DataSizeInBytes
+ PROCEDURE, PUBLIC :: isOfDataType => DimensionsWrapper7D_R8P_isOfDataType
+ PROCEDURE, PUBLIC :: toString => DimensionsWrapper7D_R8P_toString
+ PROCEDURE, PUBLIC :: PRINT => DimensionsWrapper7D_R8P_Print
+ PROCEDURE, PUBLIC :: Free => DimensionsWrapper7D_R8P_Free
+ FINAL :: DimensionsWrapper7D_R8P_Final
+END TYPE
+
+PUBLIC :: DimensionsWrapper7D_R8P_t
+
+CONTAINS
+
+SUBROUTINE DimensionsWrapper7D_R8P_Final(this)
+ !-----------------------------------------------------------------
+ !< Final procedure of DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ TYPE(DimensionsWrapper7D_R8P_t), INTENT(INOUT) :: this
+ !-----------------------------------------------------------------
+ CALL this%Free()
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R8P_Set(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Set R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(INOUT) :: this
+ CLASS(*), INTENT(IN) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ ALLOCATE (this%VALUE(SIZE(VALUE, dim=1), &
+ SIZE(VALUE, dim=2), &
+ SIZE(VALUE, dim=3), &
+ SIZE(VALUE, dim=4), &
+ SIZE(VALUE, dim=5), &
+ SIZE(VALUE, dim=6), &
+ SIZE(VALUE, dim=7)), &
+ source=VALUE, stat=err)
+ IF (err /= 0) &
+ CALL msg%Error(txt='Setting Value: Allocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ CLASS Default
+ CALL msg%Warn(txt='Setting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R8P_Get(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get R8P Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this
+ CLASS(*), INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ INTEGER(I4P), ALLOCATABLE :: ValueShape(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ CALL this%GetShape(ValueShape)
+ IF (ALL(ValueShape == SHAPE(VALUE))) THEN
+ VALUE = this%VALUE
+ ELSE
+ CALL msg%Warn(txt='Getting value: Wrong shape ('// &
+ str(no_sign=.TRUE., n=ValueShape)//'/='// &
+ str(no_sign=.TRUE., n=SHAPE(VALUE))//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+ CLASS Default
+ CALL msg%Warn(txt='Getting value: Expected data type (R8P)', &
+ file=__FILE__, line=__LINE__)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R8P_GetShape(this, ValueShape)
+ !-----------------------------------------------------------------
+ !< Get Wrapper Value Shape
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this
+ INTEGER(I4P), ALLOCATABLE, INTENT(INOUT) :: ValueShape(:)
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(ValueShape)) DEALLOCATE (ValueShape)
+ ALLOCATE (ValueShape(this%GetDimensions()))
+ ValueShape = SHAPE(this%VALUE, kind=I4P)
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_R8P_GetPointer(this) RESULT(VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic pointer to Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), TARGET, INTENT(IN) :: this
+ CLASS(*), POINTER :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ VALUE => this%VALUE
+END FUNCTION
+
+SUBROUTINE DimensionsWrapper7D_R8P_GetPolymorphic(this, VALUE)
+ !-----------------------------------------------------------------
+ !< Get Unlimited Polymorphic Wrapper Value
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this
+ CLASS(*), ALLOCATABLE, INTENT(OUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ ALLOCATE (VALUE(SIZE(this%VALUE, dim=1), &
+ SIZE(this%VALUE, dim=2), &
+ SIZE(this%VALUE, dim=3), &
+ SIZE(this%VALUE, dim=4), &
+ SIZE(this%VALUE, dim=5), &
+ SIZE(this%VALUE, dim=6), &
+ SIZE(this%VALUE, dim=7)), &
+ source=this%VALUE)
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R8P_Free(this)
+ !-----------------------------------------------------------------
+ !< Free a DimensionsWrapper7D
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(INOUT) :: this
+ INTEGER :: err
+ !-----------------------------------------------------------------
+ IF (ALLOCATED(this%VALUE)) THEN
+ DEALLOCATE (this%VALUE, stat=err)
+ IF (err /= 0) CALL msg%Error(txt='Freeing Value: Deallocation error ('// &
+ str(no_sign=.TRUE., n=err)//')', &
+ file=__FILE__, line=__LINE__)
+ END IF
+END SUBROUTINE
+
+FUNCTION DimensionsWrapper7D_R8P_DataSizeInBytes(this) RESULT(DataSizeInBytes)
+ !-----------------------------------------------------------------
+ !< Return the size of the data in bytes
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ INTEGER(I4P) :: DataSizeInBytes !< Data size in bytes
+ !-----------------------------------------------------------------
+ DataSizeInBytes = byte_size(this%value(1,1,1,1,1,1,1))*size(this%value)
+END FUNCTION DimensionsWrapper7D_R8P_DataSizeInBytes
+
+FUNCTION DimensionsWrapper7D_R8P_isOfDataType(this, Mold) RESULT(isOfDataType)
+ !-----------------------------------------------------------------
+ !< Check if Mold and Value are of the same datatype
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this !< Dimensions wrapper 7D
+ CLASS(*), INTENT(IN) :: Mold !< Mold for data type comparison
+ LOGICAL :: isOfDataType !< Boolean flag to check if Value is of the same data type as Mold
+ !-----------------------------------------------------------------
+ isOfDataType = .FALSE.
+ SELECT TYPE (Mold)
+ TYPE is (REAL(R8P))
+ isOfDataType = .TRUE.
+ END SELECT
+END FUNCTION DimensionsWrapper7D_R8P_isOfDataType
+
+SUBROUTINE DimensionsWrapper7D_R8P_toString(this, String, Separator)
+ !-----------------------------------------------------------------
+ !< Return the wrapper value as a string
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this
+ CHARACTER(len=:), ALLOCATABLE, INTENT(INOUT) :: String
+ CHARACTER(len=1), OPTIONAL, INTENT(IN) :: Separator
+ CHARACTER(len=1) :: Sep
+ INTEGER(I4P) :: idx2, idx3, idx4, idx5, idx6, idx7
+ !-----------------------------------------------------------------
+ String = ''
+ Sep = ','
+ IF (ALLOCATED(this%VALUE)) THEN
+ IF (PRESENT(Separator)) Sep = Separator
+ DO idx7 = 1, SIZE(this%VALUE, 7)
+ DO idx6 = 1, SIZE(this%VALUE, 6)
+ DO idx5 = 1, SIZE(this%VALUE, 5)
+ DO idx4 = 1, SIZE(this%VALUE, 4)
+ DO idx3 = 1, SIZE(this%VALUE, 3)
+ DO idx2 = 1, SIZE(this%VALUE, 2)
String = String // trim(str(n=this%Value(:,idx2,idx3,idx4,idx5,idx6,idx7))) // Sep
- enddo
- enddo
- enddo
- enddo
- enddo
- enddo
- String = trim(adjustl(String(:len(String)-1)))
- endif
- end subroutine
-
-
- subroutine DimensionsWrapper7D_R8P_Print(this, unit, prefix, iostat, iomsg)
- !-----------------------------------------------------------------
- !< Print Wrapper
- !-----------------------------------------------------------------
- class(DimensionsWrapper7D_R8P_t), intent(IN) :: this !< DimensionsWrapper
- integer(I4P), intent(IN) :: unit !< Logic unit.
- character(*), optional, intent(IN) :: prefix !< Prefixing string.
- integer(I4P), optional, intent(OUT) :: iostat !< IO error.
- character(*), optional, intent(OUT) :: iomsg !< IO error message.
- character(len=:), allocatable :: prefd !< Prefixing string.
- character(len=:), allocatable :: strvalue !< String value
- integer(I4P) :: iostatd !< IO error.
- character(500) :: iomsgd !< Temporary variable for IO error message.
- !-----------------------------------------------------------------
- prefd = '' ; if (present(prefix)) prefd = prefix
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ END DO
+ String = TRIM(ADJUSTL(String(:LEN(String) - 1)))
+ END IF
+END SUBROUTINE
+
+SUBROUTINE DimensionsWrapper7D_R8P_Print(this, unit, prefix, iostat, iomsg)
+ !-----------------------------------------------------------------
+ !< Print Wrapper
+ !-----------------------------------------------------------------
+ CLASS(DimensionsWrapper7D_R8P_t), INTENT(IN) :: this !< DimensionsWrapper
+ INTEGER(I4P), INTENT(IN) :: unit !< Logic unit.
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: prefix !< Prefixing string.
+ INTEGER(I4P), OPTIONAL, INTENT(OUT) :: iostat !< IO error.
+ CHARACTER(*), OPTIONAL, INTENT(OUT) :: iomsg !< IO error message.
+ CHARACTER(len=:), ALLOCATABLE :: prefd !< Prefixing string.
+ CHARACTER(len=:), ALLOCATABLE :: strvalue !< String value
+ INTEGER(I4P) :: iostatd !< IO error.
+ CHARACTER(500) :: iomsgd !< Temporary variable for IO error message.
+ !-----------------------------------------------------------------
+ prefd = ''; IF (PRESENT(prefix)) prefd = prefix
write(unit=unit,fmt='(A)', advance="no",iostat=iostatd,iomsg=iomsgd) prefd//' Data Type = R8P'//&
- ', Dimensions = '//trim(str(no_sign=.true., n=this%GetDimensions()))//&
- ', Bytes = '//trim(str(no_sign=.true., n=this%DataSizeInBytes()))//&
- ', Value = '
- call this%toString(strvalue)
- write(unit=unit,fmt=*,iostat=iostatd,iomsg=iomsgd) strvalue
- if (present(iostat)) iostat = iostatd
- if (present(iomsg)) iomsg = iomsgd
- end subroutine DimensionsWrapper7D_R8P_Print
-
-end module DimensionsWrapper7D_R8P
+ ', Dimensions = '//TRIM(str(no_sign=.TRUE., n=this%GetDimensions()))// &
+ ', Bytes = '//TRIM(str(no_sign=.TRUE., n=this%DataSizeInBytes()))// &
+ ', Value = '
+ CALL this%toString(strvalue)
+ WRITE (unit=unit, fmt=*, iostat=iostatd, iomsg=iomsgd) strvalue
+ IF (PRESENT(iostat)) iostat = iostatd
+ IF (PRESENT(iomsg)) iomsg = iomsgd
+END SUBROUTINE DimensionsWrapper7D_R8P_Print
+
+END MODULE DimensionsWrapper7D_R8P
diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90
index cebb80c3f..e69979f1c 100644
--- a/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90
+++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I2PWrapperFactory.F90
@@ -1,6 +1,6 @@
!-----------------------------------------------------------------
! FPL (Fortran Parameter List)
-! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
+! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
! Javier Principe and VÃctor Sande.
! All rights reserved.
!
@@ -18,10 +18,10 @@
! License along with this library.
!-----------------------------------------------------------------
-module I2PWrapperFactory
+MODULE I2PWrapperFactory
USE WrapperFactory
-USE PENF, only: I1P, I2P
+USE PENF, ONLY: I1P, I2P
USE DimensionsWrapper
USE DimensionsWrapper0D_I2P
USE DimensionsWrapper1D_I2P
@@ -32,322 +32,306 @@ module I2PWrapperFactory
USE DimensionsWrapper6D_I2P
USE DimensionsWrapper7D_I2P
-implicit none
-private
-
- type, extends(WrapperFactory_t) :: I2PWrapperFactory_t
- private
-
- contains
- procedure :: Wrap0D => I2PWrapperFactory_Wrap0D
- procedure :: Wrap1D => I2PWrapperFactory_Wrap1D
- procedure :: Wrap2D => I2PWrapperFactory_Wrap2D
- procedure :: Wrap3D => I2PWrapperFactory_Wrap3D
- procedure :: Wrap4D => I2PWrapperFactory_Wrap4D
- procedure :: Wrap5D => I2PWrapperFactory_Wrap5D
- procedure :: Wrap6D => I2PWrapperFactory_Wrap6D
- procedure :: Wrap7D => I2PWrapperFactory_Wrap7D
- procedure :: UnWrap0D => I2PWrapperFactory_UnWrap0D
- procedure :: UnWrap1D => I2PWrapperFactory_UnWrap1D
- procedure :: UnWrap2D => I2PWrapperFactory_UnWrap2D
- procedure :: UnWrap3D => I2PWrapperFactory_UnWrap3D
- procedure :: UnWrap4D => I2PWrapperFactory_UnWrap4D
- procedure :: UnWrap5D => I2PWrapperFactory_UnWrap5D
- procedure :: UnWrap6D => I2PWrapperFactory_UnWrap6D
- procedure :: UnWrap7D => I2PWrapperFactory_UnWrap7D
- procedure, public :: hasSameType => I2PWrapperFactory_hasSameType
- end type
-
- type(I2PWrapperFactory_t), save, public :: WrapperFactoryI2P
- !$OMP THREADPRIVATE(WrapperFactoryI2P)
-
-contains
-
- function I2PWrapperFactory_hasSameType(this, Value) result(hasSameType)
- !-----------------------------------------------------------------
- !< Check if Value type agrees with wrapper type
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- logical :: hasSameType
- !-----------------------------------------------------------------
- hasSameType = .false.
- select type(Value)
- type is (integer(I2P))
- hasSameType = .true.
- end select
- end function I2PWrapperFactory_hasSameType
-
-
- function I2PWrapperFactory_Wrap0D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 0D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value)) then
- allocate(DimensionsWrapper0D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=0_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper0D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap0D
-
-
- function I2PWrapperFactory_Wrap1D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 1D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1))) then
- allocate(DimensionsWrapper1D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=1_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper1D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap1D
-
-
- function I2PWrapperFactory_Wrap2D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 2D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1))) then
- allocate(DimensionsWrapper2D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=2_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper2D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap2D
-
-
- function I2PWrapperFactory_Wrap3D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 3D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1))) then
- allocate(DimensionsWrapper3D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=3_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper3D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap3D
-
-
- function I2PWrapperFactory_Wrap4D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 4D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1))) then
- allocate(DimensionsWrapper4D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=4_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper4D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap4D
-
-
- function I2PWrapperFactory_Wrap5D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 5D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1))) then
- allocate(DimensionsWrapper5D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=5_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper5D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap5D
-
-
- function I2PWrapperFactory_Wrap6D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 6D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1))) then
- allocate(DimensionsWrapper6D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=6_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper6D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap6D
-
-
- function I2PWrapperFactory_Wrap7D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I2P 7D Wrapper
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1,1))) then
- allocate(DimensionsWrapper7D_I2P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=7_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper7D_I2P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I2PWrapperFactory_Wrap7D
-
-
- subroutine I2PWrapperFactory_UnWrap0D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 0D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper0D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap1D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 1D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper1D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap2D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 2D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper2D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap3D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 3D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper3D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap4D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 4D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper4D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap5D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 5D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper5D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap6D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 6D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper6D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I2PWrapperFactory_UnWrap7D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I2P 7D Wrapped Value
- !-----------------------------------------------------------------
- class(I2PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper7D_I2P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-end module I2PWrapperFactory
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(WrapperFactory_t) :: I2PWrapperFactory_t
+ PRIVATE
+
+CONTAINS
+ PROCEDURE :: Wrap0D => I2PWrapperFactory_Wrap0D
+ PROCEDURE :: Wrap1D => I2PWrapperFactory_Wrap1D
+ PROCEDURE :: Wrap2D => I2PWrapperFactory_Wrap2D
+ PROCEDURE :: Wrap3D => I2PWrapperFactory_Wrap3D
+ PROCEDURE :: Wrap4D => I2PWrapperFactory_Wrap4D
+ PROCEDURE :: Wrap5D => I2PWrapperFactory_Wrap5D
+ PROCEDURE :: Wrap6D => I2PWrapperFactory_Wrap6D
+ PROCEDURE :: Wrap7D => I2PWrapperFactory_Wrap7D
+ PROCEDURE :: UnWrap0D => I2PWrapperFactory_UnWrap0D
+ PROCEDURE :: UnWrap1D => I2PWrapperFactory_UnWrap1D
+ PROCEDURE :: UnWrap2D => I2PWrapperFactory_UnWrap2D
+ PROCEDURE :: UnWrap3D => I2PWrapperFactory_UnWrap3D
+ PROCEDURE :: UnWrap4D => I2PWrapperFactory_UnWrap4D
+ PROCEDURE :: UnWrap5D => I2PWrapperFactory_UnWrap5D
+ PROCEDURE :: UnWrap6D => I2PWrapperFactory_UnWrap6D
+ PROCEDURE :: UnWrap7D => I2PWrapperFactory_UnWrap7D
+ PROCEDURE, PUBLIC :: hasSameType => I2PWrapperFactory_hasSameType
+END TYPE
+
+TYPE(I2PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryI2P
+!$OMP THREADPRIVATE(WrapperFactoryI2P)
+
+CONTAINS
+
+FUNCTION I2PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType)
+ !-----------------------------------------------------------------
+ !< Check if Value type agrees with wrapper type
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ LOGICAL :: hasSameType
+ !-----------------------------------------------------------------
+ hasSameType = .FALSE.
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I2P))
+ hasSameType = .TRUE.
+ END SELECT
+END FUNCTION I2PWrapperFactory_hasSameType
+
+FUNCTION I2PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 0D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE)) THEN
+ ALLOCATE (DimensionsWrapper0D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=0_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap0D
+
+FUNCTION I2PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 1D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1))) THEN
+ ALLOCATE (DimensionsWrapper1D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=1_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap1D
+
+FUNCTION I2PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 2D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1))) THEN
+ ALLOCATE (DimensionsWrapper2D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=2_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap2D
+
+FUNCTION I2PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 3D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper3D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=3_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap3D
+
+FUNCTION I2PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 4D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper4D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=4_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap4D
+
+FUNCTION I2PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 5D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper5D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=5_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap5D
+
+FUNCTION I2PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 6D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper6D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=6_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap6D
+
+FUNCTION I2PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I2P 7D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper7D_I2P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=7_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_I2P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I2PWrapperFactory_Wrap7D
+
+SUBROUTINE I2PWrapperFactory_UnWrap0D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 0D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap1D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 1D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap2D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 2D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap3D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 3D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap4D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 4D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap5D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 5D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap6D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 6D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I2PWrapperFactory_UnWrap7D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I2P 7D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I2PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_I2P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+END MODULE I2PWrapperFactory
diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90
index be2999f64..91e589e5e 100644
--- a/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90
+++ b/src/modules/FPL/src/Wrapper/WrapperFactory/I4PWrapperFactory.F90
@@ -1,6 +1,6 @@
!-----------------------------------------------------------------
! FPL (Fortran Parameter List)
-! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
+! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
! Javier Principe and VÃctor Sande.
! All rights reserved.
!
@@ -18,10 +18,10 @@
! License along with this library.
!-----------------------------------------------------------------
-module I4PWrapperFactory
+MODULE I4PWrapperFactory
USE WrapperFactory
-USE PENF, only: I1P, I4P
+USE PENF, ONLY: I1P, I4P
USE DimensionsWrapper
USE DimensionsWrapper0D_I4P
USE DimensionsWrapper1D_I4P
@@ -32,322 +32,306 @@ module I4PWrapperFactory
USE DimensionsWrapper6D_I4P
USE DimensionsWrapper7D_I4P
-implicit none
-private
-
- type, extends(WrapperFactory_t) :: I4PWrapperFactory_t
- private
-
- contains
- procedure :: Wrap0D => I4PWrapperFactory_Wrap0D
- procedure :: Wrap1D => I4PWrapperFactory_Wrap1D
- procedure :: Wrap2D => I4PWrapperFactory_Wrap2D
- procedure :: Wrap3D => I4PWrapperFactory_Wrap3D
- procedure :: Wrap4D => I4PWrapperFactory_Wrap4D
- procedure :: Wrap5D => I4PWrapperFactory_Wrap5D
- procedure :: Wrap6D => I4PWrapperFactory_Wrap6D
- procedure :: Wrap7D => I4PWrapperFactory_Wrap7D
- procedure :: UnWrap0D => I4PWrapperFactory_UnWrap0D
- procedure :: UnWrap1D => I4PWrapperFactory_UnWrap1D
- procedure :: UnWrap2D => I4PWrapperFactory_UnWrap2D
- procedure :: UnWrap3D => I4PWrapperFactory_UnWrap3D
- procedure :: UnWrap4D => I4PWrapperFactory_UnWrap4D
- procedure :: UnWrap5D => I4PWrapperFactory_UnWrap5D
- procedure :: UnWrap6D => I4PWrapperFactory_UnWrap6D
- procedure :: UnWrap7D => I4PWrapperFactory_UnWrap7D
- procedure, public :: hasSameType => I4PWrapperFactory_hasSameType
- end type
-
- type(I4PWrapperFactory_t), save, public :: WrapperFactoryI4P
- !$OMP THREADPRIVATE(WrapperFactoryI4P)
-
-contains
-
- function I4PWrapperFactory_hasSameType(this, Value) result(hasSameType)
- !-----------------------------------------------------------------
- !< Check if Value type agrees with wrapper type
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- logical :: hasSameType
- !-----------------------------------------------------------------
- hasSameType = .false.
- select type(Value)
- type is (integer(I4P))
- hasSameType = .true.
- end select
- end function I4PWrapperFactory_hasSameType
-
-
- function I4PWrapperFactory_Wrap0D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 0D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value)) then
- allocate(DimensionsWrapper0D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=0_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper0D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap0D
-
-
- function I4PWrapperFactory_Wrap1D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 1D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1))) then
- allocate(DimensionsWrapper1D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=1_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper1D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap1D
-
-
- function I4PWrapperFactory_Wrap2D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 2D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1))) then
- allocate(DimensionsWrapper2D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=2_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper2D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap2D
-
-
- function I4PWrapperFactory_Wrap3D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 3D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1))) then
- allocate(DimensionsWrapper3D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=3_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper3D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap3D
-
-
- function I4PWrapperFactory_Wrap4D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 4D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1))) then
- allocate(DimensionsWrapper4D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=4_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper4D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap4D
-
-
- function I4PWrapperFactory_Wrap5D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 5D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1))) then
- allocate(DimensionsWrapper5D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=5_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper5D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap5D
-
-
- function I4PWrapperFactory_Wrap6D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 6D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1))) then
- allocate(DimensionsWrapper6D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=6_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper6D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap6D
-
-
- function I4PWrapperFactory_Wrap7D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create I4P 7D Wrapper
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1,1))) then
- allocate(DimensionsWrapper7D_I4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=7_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper7D_I4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function I4PWrapperFactory_Wrap7D
-
-
- subroutine I4PWrapperFactory_UnWrap0D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 0D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper0D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap1D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 1D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper1D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap2D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 2D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper2D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap3D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 3D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper3D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap4D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 4D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper4D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap5D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 5D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper5D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap6D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 6D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper6D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine I4PWrapperFactory_UnWrap7D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the I4P 7D Wrapped Value
- !-----------------------------------------------------------------
- class(I4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper7D_I4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-end module I4PWrapperFactory
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(WrapperFactory_t) :: I4PWrapperFactory_t
+ PRIVATE
+
+CONTAINS
+ PROCEDURE :: Wrap0D => I4PWrapperFactory_Wrap0D
+ PROCEDURE :: Wrap1D => I4PWrapperFactory_Wrap1D
+ PROCEDURE :: Wrap2D => I4PWrapperFactory_Wrap2D
+ PROCEDURE :: Wrap3D => I4PWrapperFactory_Wrap3D
+ PROCEDURE :: Wrap4D => I4PWrapperFactory_Wrap4D
+ PROCEDURE :: Wrap5D => I4PWrapperFactory_Wrap5D
+ PROCEDURE :: Wrap6D => I4PWrapperFactory_Wrap6D
+ PROCEDURE :: Wrap7D => I4PWrapperFactory_Wrap7D
+ PROCEDURE :: UnWrap0D => I4PWrapperFactory_UnWrap0D
+ PROCEDURE :: UnWrap1D => I4PWrapperFactory_UnWrap1D
+ PROCEDURE :: UnWrap2D => I4PWrapperFactory_UnWrap2D
+ PROCEDURE :: UnWrap3D => I4PWrapperFactory_UnWrap3D
+ PROCEDURE :: UnWrap4D => I4PWrapperFactory_UnWrap4D
+ PROCEDURE :: UnWrap5D => I4PWrapperFactory_UnWrap5D
+ PROCEDURE :: UnWrap6D => I4PWrapperFactory_UnWrap6D
+ PROCEDURE :: UnWrap7D => I4PWrapperFactory_UnWrap7D
+ PROCEDURE, PUBLIC :: hasSameType => I4PWrapperFactory_hasSameType
+END TYPE
+
+TYPE(I4PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryI4P
+!$OMP THREADPRIVATE(WrapperFactoryI4P)
+
+CONTAINS
+
+FUNCTION I4PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType)
+ !-----------------------------------------------------------------
+ !< Check if Value type agrees with wrapper type
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ LOGICAL :: hasSameType
+ !-----------------------------------------------------------------
+ hasSameType = .FALSE.
+ SELECT TYPE (VALUE)
+ TYPE is (INTEGER(I4P))
+ hasSameType = .TRUE.
+ END SELECT
+END FUNCTION I4PWrapperFactory_hasSameType
+
+FUNCTION I4PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 0D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE)) THEN
+ ALLOCATE (DimensionsWrapper0D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=0_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap0D
+
+FUNCTION I4PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 1D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1))) THEN
+ ALLOCATE (DimensionsWrapper1D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=1_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap1D
+
+FUNCTION I4PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 2D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1))) THEN
+ ALLOCATE (DimensionsWrapper2D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=2_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap2D
+
+FUNCTION I4PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 3D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper3D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=3_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap3D
+
+FUNCTION I4PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 4D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper4D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=4_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap4D
+
+FUNCTION I4PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 5D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper5D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=5_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap5D
+
+FUNCTION I4PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 6D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper6D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=6_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap6D
+
+FUNCTION I4PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create I4P 7D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper7D_I4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=7_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_I4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION I4PWrapperFactory_Wrap7D
+
+SUBROUTINE I4PWrapperFactory_UnWrap0D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 0D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap1D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 1D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap2D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 2D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap3D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 3D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap4D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 4D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap5D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 5D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap6D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 6D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE I4PWrapperFactory_UnWrap7D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the I4P 7D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(I4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_I4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+END MODULE I4PWrapperFactory
diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90
index f58934d4d..a1f125930 100644
--- a/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90
+++ b/src/modules/FPL/src/Wrapper/WrapperFactory/R4PWrapperFactory.F90
@@ -1,6 +1,6 @@
!-----------------------------------------------------------------
! FPL (Fortran Parameter List)
-! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
+! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
! Javier Principe and VÃctor Sande.
! All rights reserved.
!
@@ -18,10 +18,10 @@
! License along with this library.
!-----------------------------------------------------------------
-module R4PWrapperFactory
+MODULE R4PWrapperFactory
USE WrapperFactory
-USE PENF, only: I1P, R4P
+USE PENF, ONLY: I1P, R4P
USE DimensionsWrapper
USE DimensionsWrapper0D_R4P
USE DimensionsWrapper1D_R4P
@@ -32,322 +32,306 @@ module R4PWrapperFactory
USE DimensionsWrapper6D_R4P
USE DimensionsWrapper7D_R4P
-implicit none
-private
-
- type, extends(WrapperFactory_t) :: R4PWrapperFactory_t
- private
-
- contains
- procedure :: Wrap0D => R4PWrapperFactory_Wrap0D
- procedure :: Wrap1D => R4PWrapperFactory_Wrap1D
- procedure :: Wrap2D => R4PWrapperFactory_Wrap2D
- procedure :: Wrap3D => R4PWrapperFactory_Wrap3D
- procedure :: Wrap4D => R4PWrapperFactory_Wrap4D
- procedure :: Wrap5D => R4PWrapperFactory_Wrap5D
- procedure :: Wrap6D => R4PWrapperFactory_Wrap6D
- procedure :: Wrap7D => R4PWrapperFactory_Wrap7D
- procedure :: UnWrap0D => R4PWrapperFactory_UnWrap0D
- procedure :: UnWrap1D => R4PWrapperFactory_UnWrap1D
- procedure :: UnWrap2D => R4PWrapperFactory_UnWrap2D
- procedure :: UnWrap3D => R4PWrapperFactory_UnWrap3D
- procedure :: UnWrap4D => R4PWrapperFactory_UnWrap4D
- procedure :: UnWrap5D => R4PWrapperFactory_UnWrap5D
- procedure :: UnWrap6D => R4PWrapperFactory_UnWrap6D
- procedure :: UnWrap7D => R4PWrapperFactory_UnWrap7D
- procedure, public :: hasSameType => R4PWrapperFactory_hasSameType
- end type
-
- type(R4PWrapperFactory_t), save, public :: WrapperFactoryR4P
- !$OMP THREADPRIVATE(WrapperFactoryR4P)
-
-contains
-
- function R4PWrapperFactory_hasSameType(this, Value) result(hasSameType)
- !-----------------------------------------------------------------
- !< Check if Value type agrees with wrapper type
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- logical :: hasSameType
- !-----------------------------------------------------------------
- hasSameType = .false.
- select type(Value)
- type is (real(R4P))
- hasSameType = .true.
- end select
- end function R4PWrapperFactory_hasSameType
-
-
- function R4PWrapperFactory_Wrap0D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 0D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value)) then
- allocate(DimensionsWrapper0D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=0_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper0D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap0D
-
-
- function R4PWrapperFactory_Wrap1D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 1D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1))) then
- allocate(DimensionsWrapper1D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=1_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper1D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap1D
-
-
- function R4PWrapperFactory_Wrap2D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 2D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1))) then
- allocate(DimensionsWrapper2D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=2_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper2D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap2D
-
-
- function R4PWrapperFactory_Wrap3D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 3D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1))) then
- allocate(DimensionsWrapper3D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=3_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper3D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap3D
-
-
- function R4PWrapperFactory_Wrap4D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 4D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1))) then
- allocate(DimensionsWrapper4D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=4_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper4D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap4D
-
-
- function R4PWrapperFactory_Wrap5D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 5D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1))) then
- allocate(DimensionsWrapper5D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=5_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper5D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap5D
-
-
- function R4PWrapperFactory_Wrap6D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 6D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1))) then
- allocate(DimensionsWrapper6D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=6_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper6D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap6D
-
-
- function R4PWrapperFactory_Wrap7D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R4P 7D Wrapper
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1,1))) then
- allocate(DimensionsWrapper7D_R4P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=7_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper7D_R4P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R4PWrapperFactory_Wrap7D
-
-
- subroutine R4PWrapperFactory_UnWrap0D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 0D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper0D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap1D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 1D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper1D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap2D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 2D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper2D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap3D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 3D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper3D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap4D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 4D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper4D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap5D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 5D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper5D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap6D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 6D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper6D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R4PWrapperFactory_UnWrap7D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R4P 7D Wrapped Value
- !-----------------------------------------------------------------
- class(R4PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper7D_R4P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-end module R4PWrapperFactory
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(WrapperFactory_t) :: R4PWrapperFactory_t
+ PRIVATE
+
+CONTAINS
+ PROCEDURE :: Wrap0D => R4PWrapperFactory_Wrap0D
+ PROCEDURE :: Wrap1D => R4PWrapperFactory_Wrap1D
+ PROCEDURE :: Wrap2D => R4PWrapperFactory_Wrap2D
+ PROCEDURE :: Wrap3D => R4PWrapperFactory_Wrap3D
+ PROCEDURE :: Wrap4D => R4PWrapperFactory_Wrap4D
+ PROCEDURE :: Wrap5D => R4PWrapperFactory_Wrap5D
+ PROCEDURE :: Wrap6D => R4PWrapperFactory_Wrap6D
+ PROCEDURE :: Wrap7D => R4PWrapperFactory_Wrap7D
+ PROCEDURE :: UnWrap0D => R4PWrapperFactory_UnWrap0D
+ PROCEDURE :: UnWrap1D => R4PWrapperFactory_UnWrap1D
+ PROCEDURE :: UnWrap2D => R4PWrapperFactory_UnWrap2D
+ PROCEDURE :: UnWrap3D => R4PWrapperFactory_UnWrap3D
+ PROCEDURE :: UnWrap4D => R4PWrapperFactory_UnWrap4D
+ PROCEDURE :: UnWrap5D => R4PWrapperFactory_UnWrap5D
+ PROCEDURE :: UnWrap6D => R4PWrapperFactory_UnWrap6D
+ PROCEDURE :: UnWrap7D => R4PWrapperFactory_UnWrap7D
+ PROCEDURE, PUBLIC :: hasSameType => R4PWrapperFactory_hasSameType
+END TYPE
+
+TYPE(R4PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryR4P
+!$OMP THREADPRIVATE(WrapperFactoryR4P)
+
+CONTAINS
+
+FUNCTION R4PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType)
+ !-----------------------------------------------------------------
+ !< Check if Value type agrees with wrapper type
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ LOGICAL :: hasSameType
+ !-----------------------------------------------------------------
+ hasSameType = .FALSE.
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R4P))
+ hasSameType = .TRUE.
+ END SELECT
+END FUNCTION R4PWrapperFactory_hasSameType
+
+FUNCTION R4PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 0D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE)) THEN
+ ALLOCATE (DimensionsWrapper0D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=0_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap0D
+
+FUNCTION R4PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 1D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1))) THEN
+ ALLOCATE (DimensionsWrapper1D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=1_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap1D
+
+FUNCTION R4PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 2D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1))) THEN
+ ALLOCATE (DimensionsWrapper2D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=2_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap2D
+
+FUNCTION R4PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 3D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper3D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=3_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap3D
+
+FUNCTION R4PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 4D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper4D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=4_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap4D
+
+FUNCTION R4PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 5D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper5D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=5_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap5D
+
+FUNCTION R4PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 6D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper6D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=6_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap6D
+
+FUNCTION R4PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R4P 7D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper7D_R4P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=7_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_R4P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R4PWrapperFactory_Wrap7D
+
+SUBROUTINE R4PWrapperFactory_UnWrap0D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 0D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap1D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 1D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap2D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 2D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap3D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 3D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap4D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 4D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap5D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 5D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap6D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 6D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R4PWrapperFactory_UnWrap7D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R4P 7D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R4PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_R4P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+END MODULE R4PWrapperFactory
diff --git a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90 b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90
index 92bcab984..324e8731c 100644
--- a/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90
+++ b/src/modules/FPL/src/Wrapper/WrapperFactory/R8PWrapperFactory.F90
@@ -1,6 +1,6 @@
!-----------------------------------------------------------------
! FPL (Fortran Parameter List)
-! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
+! Copyright (c) 2015 Santiago Badia, Alberto F. MartÃn,
! Javier Principe and VÃctor Sande.
! All rights reserved.
!
@@ -18,10 +18,10 @@
! License along with this library.
!-----------------------------------------------------------------
-module R8PWrapperFactory
+MODULE R8PWrapperFactory
USE WrapperFactory
-USE PENF, only: I1P, R8P
+USE PENF, ONLY: I1P, R8P
USE DimensionsWrapper
USE DimensionsWrapper0D_R8P
USE DimensionsWrapper1D_R8P
@@ -32,322 +32,306 @@ module R8PWrapperFactory
USE DimensionsWrapper6D_R8P
USE DimensionsWrapper7D_R8P
-implicit none
-private
-
- type, extends(WrapperFactory_t) :: R8PWrapperFactory_t
- private
-
- contains
- procedure :: Wrap0D => R8PWrapperFactory_Wrap0D
- procedure :: Wrap1D => R8PWrapperFactory_Wrap1D
- procedure :: Wrap2D => R8PWrapperFactory_Wrap2D
- procedure :: Wrap3D => R8PWrapperFactory_Wrap3D
- procedure :: Wrap4D => R8PWrapperFactory_Wrap4D
- procedure :: Wrap5D => R8PWrapperFactory_Wrap5D
- procedure :: Wrap6D => R8PWrapperFactory_Wrap6D
- procedure :: Wrap7D => R8PWrapperFactory_Wrap7D
- procedure :: UnWrap0D => R8PWrapperFactory_UnWrap0D
- procedure :: UnWrap1D => R8PWrapperFactory_UnWrap1D
- procedure :: UnWrap2D => R8PWrapperFactory_UnWrap2D
- procedure :: UnWrap3D => R8PWrapperFactory_UnWrap3D
- procedure :: UnWrap4D => R8PWrapperFactory_UnWrap4D
- procedure :: UnWrap5D => R8PWrapperFactory_UnWrap5D
- procedure :: UnWrap6D => R8PWrapperFactory_UnWrap6D
- procedure :: UnWrap7D => R8PWrapperFactory_UnWrap7D
- procedure, public :: hasSameType => R8PWrapperFactory_hasSameType
- end type
-
- type(R8PWrapperFactory_t), save, public :: WrapperFactoryR8P
- !$OMP THREADPRIVATE(WrapperFactoryR8P)
-
-contains
-
- function R8PWrapperFactory_hasSameType(this, Value) result(hasSameType)
- !-----------------------------------------------------------------
- !< Check if Value type agrees with wrapper type
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- logical :: hasSameType
- !-----------------------------------------------------------------
- hasSameType = .false.
- select type(Value)
- type is (real(R8P))
- hasSameType = .true.
- end select
- end function R8PWrapperFactory_hasSameType
-
-
- function R8PWrapperFactory_Wrap0D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 0D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value)) then
- allocate(DimensionsWrapper0D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=0_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper0D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap0D
-
-
- function R8PWrapperFactory_Wrap1D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 1D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1))) then
- allocate(DimensionsWrapper1D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=1_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper1D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap1D
-
-
- function R8PWrapperFactory_Wrap2D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 2D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1))) then
- allocate(DimensionsWrapper2D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=2_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper2D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap2D
-
-
- function R8PWrapperFactory_Wrap3D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 3D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1))) then
- allocate(DimensionsWrapper3D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=3_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper3D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap3D
-
-
- function R8PWrapperFactory_Wrap4D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 4D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1))) then
- allocate(DimensionsWrapper4D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=4_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper4D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap4D
-
-
- function R8PWrapperFactory_Wrap5D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 5D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1))) then
- allocate(DimensionsWrapper5D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=5_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper5D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap5D
-
-
- function R8PWrapperFactory_Wrap6D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 6D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1))) then
- allocate(DimensionsWrapper6D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=6_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper6D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap6D
-
-
- function R8PWrapperFactory_Wrap7D(this, Value) result(Wrapper)
- !-----------------------------------------------------------------
- !< Create R8P 7D Wrapper
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(*), intent(IN) :: Value(1:,1:,1:,1:,1:,1:,1:)
- class(DimensionsWrapper_t), pointer :: Wrapper
- !-----------------------------------------------------------------
- if(this%hasSameType(Value(1,1,1,1,1,1,1))) then
- allocate(DimensionsWrapper7D_R8P_t::Wrapper)
- call Wrapper%SetDimensions(Dimensions=7_I1P)
- select type (Wrapper)
- type is(DimensionsWrapper7D_R8P_t)
- call Wrapper%Set(Value=Value)
- end select
- endif
- end function R8PWrapperFactory_Wrap7D
-
-
- subroutine R8PWrapperFactory_UnWrap0D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 0D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper0D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap1D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 1D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper1D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap2D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 2D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper2D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap3D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 3D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper3D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap4D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 4D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper4D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap5D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 5D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper5D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap6D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 6D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper6D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-
- subroutine R8PWrapperFactory_UnWrap7D(this, Wrapper, Value)
- !-----------------------------------------------------------------
- !< Return the R8P 7D Wrapped Value
- !-----------------------------------------------------------------
- class(R8PWrapperFactory_t), intent(IN) :: this
- class(DimensionsWrapper_t), pointer, intent(IN) :: Wrapper
- class(*), intent(INOUT) :: Value(:,:,:,:,:,:,:)
- !-----------------------------------------------------------------
- select type (Wrapper)
- type is(DimensionsWrapper7D_R8P_t)
- call Wrapper%Get(Value = Value)
- end select
- end subroutine
-
-end module R8PWrapperFactory
+IMPLICIT NONE
+PRIVATE
+
+TYPE, EXTENDS(WrapperFactory_t) :: R8PWrapperFactory_t
+ PRIVATE
+
+CONTAINS
+ PROCEDURE :: Wrap0D => R8PWrapperFactory_Wrap0D
+ PROCEDURE :: Wrap1D => R8PWrapperFactory_Wrap1D
+ PROCEDURE :: Wrap2D => R8PWrapperFactory_Wrap2D
+ PROCEDURE :: Wrap3D => R8PWrapperFactory_Wrap3D
+ PROCEDURE :: Wrap4D => R8PWrapperFactory_Wrap4D
+ PROCEDURE :: Wrap5D => R8PWrapperFactory_Wrap5D
+ PROCEDURE :: Wrap6D => R8PWrapperFactory_Wrap6D
+ PROCEDURE :: Wrap7D => R8PWrapperFactory_Wrap7D
+ PROCEDURE :: UnWrap0D => R8PWrapperFactory_UnWrap0D
+ PROCEDURE :: UnWrap1D => R8PWrapperFactory_UnWrap1D
+ PROCEDURE :: UnWrap2D => R8PWrapperFactory_UnWrap2D
+ PROCEDURE :: UnWrap3D => R8PWrapperFactory_UnWrap3D
+ PROCEDURE :: UnWrap4D => R8PWrapperFactory_UnWrap4D
+ PROCEDURE :: UnWrap5D => R8PWrapperFactory_UnWrap5D
+ PROCEDURE :: UnWrap6D => R8PWrapperFactory_UnWrap6D
+ PROCEDURE :: UnWrap7D => R8PWrapperFactory_UnWrap7D
+ PROCEDURE, PUBLIC :: hasSameType => R8PWrapperFactory_hasSameType
+END TYPE
+
+TYPE(R8PWrapperFactory_t), SAVE, PUBLIC :: WrapperFactoryR8P
+!$OMP THREADPRIVATE(WrapperFactoryR8P)
+
+CONTAINS
+
+FUNCTION R8PWrapperFactory_hasSameType(this, VALUE) RESULT(hasSameType)
+ !-----------------------------------------------------------------
+ !< Check if Value type agrees with wrapper type
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ LOGICAL :: hasSameType
+ !-----------------------------------------------------------------
+ hasSameType = .FALSE.
+ SELECT TYPE (VALUE)
+ TYPE is (REAL(R8P))
+ hasSameType = .TRUE.
+ END SELECT
+END FUNCTION R8PWrapperFactory_hasSameType
+
+FUNCTION R8PWrapperFactory_Wrap0D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 0D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE)) THEN
+ ALLOCATE (DimensionsWrapper0D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=0_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap0D
+
+FUNCTION R8PWrapperFactory_Wrap1D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 1D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1))) THEN
+ ALLOCATE (DimensionsWrapper1D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=1_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap1D
+
+FUNCTION R8PWrapperFactory_Wrap2D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 2D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1))) THEN
+ ALLOCATE (DimensionsWrapper2D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=2_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap2D
+
+FUNCTION R8PWrapperFactory_Wrap3D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 3D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper3D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=3_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap3D
+
+FUNCTION R8PWrapperFactory_Wrap4D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 4D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper4D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=4_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap4D
+
+FUNCTION R8PWrapperFactory_Wrap5D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 5D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper5D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=5_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap5D
+
+FUNCTION R8PWrapperFactory_Wrap6D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 6D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper6D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=6_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap6D
+
+FUNCTION R8PWrapperFactory_Wrap7D(this, VALUE) RESULT(Wrapper)
+ !-----------------------------------------------------------------
+ !< Create R8P 7D Wrapper
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(*), INTENT(IN) :: VALUE(1:, 1:, 1:, 1:, 1:, 1:, 1:)
+ CLASS(DimensionsWrapper_t), POINTER :: Wrapper
+ !-----------------------------------------------------------------
+ IF (this%hasSameType(VALUE(1, 1, 1, 1, 1, 1, 1))) THEN
+ ALLOCATE (DimensionsWrapper7D_R8P_t :: Wrapper)
+ CALL Wrapper%SetDimensions(Dimensions=7_I1P)
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_R8P_t)
+ CALL Wrapper%Set(VALUE=VALUE)
+ END SELECT
+ END IF
+END FUNCTION R8PWrapperFactory_Wrap7D
+
+SUBROUTINE R8PWrapperFactory_UnWrap0D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 0D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper0D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap1D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 1D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper1D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap2D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 2D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper2D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap3D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 3D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper3D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap4D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 4D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper4D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap5D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 5D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper5D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap6D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 6D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper6D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+SUBROUTINE R8PWrapperFactory_UnWrap7D(this, Wrapper, VALUE)
+ !-----------------------------------------------------------------
+ !< Return the R8P 7D Wrapped Value
+ !-----------------------------------------------------------------
+ CLASS(R8PWrapperFactory_t), INTENT(IN) :: this
+ CLASS(DimensionsWrapper_t), POINTER, INTENT(IN) :: Wrapper
+ CLASS(*), INTENT(INOUT) :: VALUE(:, :, :, :, :, :, :)
+ !-----------------------------------------------------------------
+ SELECT TYPE (Wrapper)
+ TYPE is (DimensionsWrapper7D_R8P_t)
+ CALL Wrapper%Get(VALUE=VALUE)
+ END SELECT
+END SUBROUTINE
+
+END MODULE R8PWrapperFactory
diff --git a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90 b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90
index 23cf3a4c6..9124acb57 100644
--- a/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90
+++ b/src/modules/FPL/src/Wrapper/WrapperFactoryListSingleton.F90
@@ -18,7 +18,7 @@
! License along with this library.
!-----------------------------------------------------------------
-module WrapperFactoryListSingleton
+MODULE WrapperFactoryListSingleton
USE WrapperFactoryList
USE DLCAWrapperFactory
@@ -30,23 +30,23 @@ module WrapperFactoryListSingleton
USE R4PWrapperFactory
USE R8PWrapperFactory
-implicit none
-private
+IMPLICIT NONE
+PRIVATE
- type(WrapperFactoryList_t), save :: TheWrapperFactoryList
- !$OMP THREADPRIVATE(TheWrapperFactoryList)
+TYPE(WrapperFactoryList_t), SAVE :: TheWrapperFactoryList
+!$OMP THREADPRIVATE(TheWrapperFactoryList)
-public :: TheWrapperFactoryList
-public :: TheWrapperFactoryList_Init
+PUBLIC :: TheWrapperFactoryList
+PUBLIC :: TheWrapperFactoryList_Init
-contains
+CONTAINS
- subroutine TheWrapperFactoryList_Init()
- !-----------------------------------------------------------------
- !< Set the dimensions of the Value contained in the wrapper
- !-----------------------------------------------------------------
- ! Add some Wrapper Factories to the list
- call TheWrapperFactoryList%Init()
+SUBROUTINE TheWrapperFactoryList_Init()
+ !-----------------------------------------------------------------
+ !< Set the dimensions of the Value contained in the wrapper
+ !-----------------------------------------------------------------
+ ! Add some Wrapper Factories to the list
+ CALL TheWrapperFactoryList%Init()
call TheWrapperFactoryList%AddWrapperFactory(key='I1P', WrapperFactory=WrapperFactoryI1P)
call TheWrapperFactoryList%AddWrapperFactory(key='I2P', WrapperFactory=WrapperFactoryI2P)
call TheWrapperFactoryList%AddWrapperFactory(key='I4P', WrapperFactory=WrapperFactoryI4P)
@@ -55,6 +55,6 @@ subroutine TheWrapperFactoryList_Init()
call TheWrapperFactoryList%AddWrapperFactory(key='R8P', WrapperFactory=WrapperFactoryR8P)
call TheWrapperFactoryList%AddWrapperFactory(key='L', WrapperFactory=WrapperFactoryL)
call TheWrapperFactoryList%AddWrapperFactory(key='DLCA', WrapperFactory=WrapperFactoryDLCA)
- end subroutine TheWrapperFactoryList_Init
+END SUBROUTINE TheWrapperFactoryList_Init
-end module WrapperFactoryListSingleton
+END MODULE WrapperFactoryListSingleton
diff --git a/src/modules/ForceVector/src/ForceVector_Method.F90 b/src/modules/ForceVector/src/ForceVector_Method.F90
index 3e4deb1af..3cf947d31 100644
--- a/src/modules/ForceVector/src/ForceVector_Method.F90
+++ b/src/modules/ForceVector/src/ForceVector_Method.F90
@@ -16,12 +16,14 @@
!
MODULE ForceVector_Method
-USE BaseType
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: ElemShapeData_, FEVariable_, FEVariableScalar_, &
+ FEVariableVector_, FEVariableMatrix_
IMPLICIT NONE
PRIVATE
PUBLIC :: ForceVector
+PUBLIC :: ForceVector_
!----------------------------------------------------------------------------
! ForceVector
@@ -39,13 +41,45 @@ MODULE ForceVector_Method
! F_{I}=\int_{\Omega}N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_1(test) RESULT(ans)
+INTERFACE
+ MODULE FUNCTION ForceVector1(test) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
REAL(DFP), ALLOCATABLE :: ans(:)
- END FUNCTION ForceVector_1
+ END FUNCTION ForceVector1
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector1
END INTERFACE ForceVector
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 4 May 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! This subroutine computes the following expression:
+!
+! $$
+! F_{I}=\int_{\Omega}N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_1(test, ans, tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_1
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_1
+END INTERFACE ForceVector_
+
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
@@ -60,17 +94,21 @@ END FUNCTION ForceVector_1
! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_2b(test, c) RESULT(ans)
+INTERFACE
+ MODULE FUNCTION ForceVector2(test, c, crank) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
- REAL(DFP), INTENT(IN) :: c(:)
- !! defined on quadrature point
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:)
- END FUNCTION ForceVector_2b
+ END FUNCTION ForceVector2
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector2
END INTERFACE ForceVector
!----------------------------------------------------------------------------
-! ForceVector
+! ForceVector_
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -80,17 +118,23 @@ END FUNCTION ForceVector_2b
!# Introduction
!
! $$
-! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! F_{I}=\int_{\Omega} c N^{I} d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_2(test, c, crank) RESULT(ans)
+INTERFACE
+ MODULE SUBROUTINE ForceVector_2(test, c, crank, ans, tsize)
CLASS(ElemshapeData_), INTENT(IN) :: test
TYPE(FEVariable_), INTENT(IN) :: c
+ !! Scalar variables
TYPE(FEVariableScalar_), INTENT(IN) :: crank
- REAL(DFP), ALLOCATABLE :: ans(:)
- END FUNCTION ForceVector_2
-END INTERFACE ForceVector
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_2
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_2
+END INTERFACE ForceVector_
!----------------------------------------------------------------------------
! ForceVector
@@ -105,18 +149,52 @@ END FUNCTION ForceVector_2
! This routine computes the following integral
!
! $$
-! F(i,I)=\int_{\Omega}v_{i}N^{I}d\Omega
+! F(i,I)=\int_{\Omega}c_{i}N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_3(test, c, crank) RESULT(ans)
+INTERFACE
+ MODULE FUNCTION ForceVector3(test, c, crank) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
TYPE(FEVariable_), INTENT(IN) :: c
TYPE(FEVariableVector_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION ForceVector_3
+ END FUNCTION ForceVector3
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector3
END INTERFACE ForceVector
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! This routine computes the following integral
+!
+! $$
+! F(i,I)=\int_{\Omega}v_{i}N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_3(test, c, crank, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE ForceVector_3
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_3
+END INTERFACE ForceVector_
+
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
@@ -130,18 +208,52 @@ END FUNCTION ForceVector_3
! This routine computes the following integral
!
! $$
-! F(i,j,I)=\int_{\Omega}k_{ij}N^{I}d\Omega
+! F(i,j,I)=\int_{\Omega}c_{ij}N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_4(test, c, crank) RESULT(ans)
+INTERFACE
+ MODULE FUNCTION ForceVector4(test, c, crank) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
TYPE(FEVariable_), INTENT(IN) :: c
TYPE(FEVariableMatrix_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION ForceVector_4
+ END FUNCTION ForceVector4
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector4
END INTERFACE ForceVector
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! This routine computes the following integral
+!
+! $$
+! F(i,j,I)=\int_{\Omega}k_{ij}N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_4(test, c, crank, ans, dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE ForceVector_4
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_4
+END INTERFACE ForceVector_
+
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
@@ -158,20 +270,24 @@ END FUNCTION ForceVector_4
! F_{I}=\int_{\Omega}\rho_{1}\rho_{2}N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_5(test, c1, c1rank, c2, c2rank) &
- & RESULT(ans)
+INTERFACE
+ MODULE FUNCTION ForceVector5(test, c1, c1rank, c2, c2rank) &
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
TYPE(FEVariable_), INTENT(IN) :: c1
TYPE(FEVariable_), INTENT(IN) :: c2
TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:)
- END FUNCTION ForceVector_5
+ END FUNCTION ForceVector5
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector5
END INTERFACE ForceVector
!----------------------------------------------------------------------------
-! ForceVector
+! ForceVector_
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -180,28 +296,82 @@ END FUNCTION ForceVector_5
!
!# Introduction
!
-! This routine computes the following integral.
+! This routine computes the following integral
!
! $$
-!
+! F_{I}=\int_{\Omega}c_{1}c_{2}N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_6(test, c1, c1rank, c2, c2rank) &
- & RESULT(ans)
+INTERFACE
+ MODULE SUBROUTINE ForceVector_5(test, c1, c1rank, c2, c2rank, ans, &
+ tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_5
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_5
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE FUNCTION ForceVector6(test, c1, c1rank, c2, c2rank) &
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
TYPE(FEVariable_), INTENT(IN) :: c1
TYPE(FEVariable_), INTENT(IN) :: c2
TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
TYPE(FEVariableVector_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION ForceVector_6
+ END FUNCTION ForceVector6
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector6
END INTERFACE ForceVector
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_6(test, c1, c1rank, c2, c2rank, ans, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE ForceVector_6
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_6
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
@@ -214,16 +384,363 @@ END FUNCTION ForceVector_6
! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega
! $$
-INTERFACE ForceVector
- MODULE PURE FUNCTION ForceVector_7(test, c1, c1rank, c2, c2rank) &
- & RESULT(ans)
+INTERFACE
+ MODULE FUNCTION ForceVector7(test, c1, c1rank, c2, c2rank) &
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
TYPE(FEVariable_), INTENT(IN) :: c1
TYPE(FEVariable_), INTENT(IN) :: c2
TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION ForceVector_7
+ END FUNCTION ForceVector7
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector7
END INTERFACE ForceVector
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! This routine computes the following.
+!
+! $$
+! F(i,j,I)=\int_{\Omega}\rho k_{ij}N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_7(test, c1, c1rank, c2, c2rank, ans, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE ForceVector_7
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_7
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE FUNCTION ForceVector8(test, c) RESULT(ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ REAL(DFP), INTENT(IN) :: c(:)
+ !! defined on quadrature point
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ END FUNCTION ForceVector8
+END INTERFACE
+
+INTERFACE ForceVector
+ MODULE PROCEDURE ForceVector8
+END INTERFACE ForceVector
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_8(test, c, ans, tsize)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ REAL(DFP), INTENT(IN) :: c(:)
+ !! defined on quadrature point
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_8
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_8
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_9( &
+ N, js, ws, thickness, nns, nips, c, ans, tsize)
+ REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips
+ REAL(DFP), INTENT(IN) :: c(:)
+ !! defined on quadrature point
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_9
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_9
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_10( &
+ N, js, ws, thickness, nns, nips, c, skipVertices, tVertices, ans, tsize)
+ REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips
+ REAL(DFP), INTENT(IN) :: c(:)
+ !! defined on quadrature point
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ INTEGER(I4B), INTENT(IN) :: tVertices
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_10
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_10
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_11( &
+ spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, &
+ nips, nipt, c, ans, tsize)
+ REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:)
+ REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt
+ REAL(DFP), INTENT(IN) :: c(:, :)
+ !! defined on quadrature point
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Force vector is returned in DOF format
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_11
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_11
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_12( &
+ spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, &
+ nips, nipt, c, skipVertices, tSpaceVertices, tTimeVertices, ans, tsize)
+ REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:)
+ REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt
+ REAL(DFP), INTENT(IN) :: c(:, :)
+ !! defined on quadrature point
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_12
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_12
+END INTERFACE ForceVector_
+
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_13( &
+ N, js, ws, thickness, nns, nips, ans, tsize)
+ REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_13
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_13
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_14( &
+ N, js, ws, thickness, nns, nips, skipVertices, tVertices, ans, tsize)
+ REAL(DFP), INTENT(IN) :: N(:, :), js(:), ws(:), thickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ INTEGER(I4B), INTENT(IN) :: tVertices
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_14
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_14
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_15( &
+ spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, &
+ nips, nipt, ans, tsize)
+ REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:)
+ REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! Force vector is returned in DOF format
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_15
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_15
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+!
+!# Introduction
+!
+! $$
+! F_{I}=\int_{\Omega}\rho N^{I}d\Omega
+! $$
+
+INTERFACE
+ MODULE SUBROUTINE ForceVector_16( &
+ spaceN, timeN, js, ws, jt, wt, spaceThickness, timeThickness, nns, nnt, &
+ nips, nipt, skipVertices, tSpaceVertices, tTimeVertices, ans, tsize)
+ REAL(DFP), INTENT(IN) :: spaceN(:, :), js(:), ws(:), spaceThickness(:)
+ REAL(DFP), INTENT(IN) :: timeN(:, :), jt(:), wt(:), timeThickness(:)
+ INTEGER(I4B), INTENT(IN) :: nns, nips, nnt, nipt
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ END SUBROUTINE ForceVector_16
+END INTERFACE
+
+INTERFACE ForceVector_
+ MODULE PROCEDURE ForceVector_16
+END INTERFACE ForceVector_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE ForceVector_Method
diff --git a/src/modules/Geometry/CMakeLists.txt b/src/modules/Geometry/CMakeLists.txt
index 8c398fbc6..6158cffd4 100644
--- a/src/modules/Geometry/CMakeLists.txt
+++ b/src/modules/Geometry/CMakeLists.txt
@@ -1,34 +1,24 @@
-# 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}/ReferenceElement_Method.F90
- ${src_path}/ReferencePoint_Method.F90
- ${src_path}/Line_Method.F90
- ${src_path}/ReferenceLine_Method.F90
- ${src_path}/Triangle_Method.F90
- ${src_path}/Plane_Method.F90
- ${src_path}/ReferenceTriangle_Method.F90
- ${src_path}/ReferenceQuadrangle_Method.F90
- ${src_path}/ReferenceTetrahedron_Method.F90
- ${src_path}/ReferenceHexahedron_Method.F90
- ${src_path}/ReferencePrism_Method.F90
- ${src_path}/ReferencePyramid_Method.F90
- ${src_path}/Geometry_Method.F90
-)
\ No newline at end of file
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferenceElement_Method.F90
+ ${src_path}/Plane_Method.F90
+ ${src_path}/Geometry_Method.F90)
+
diff --git a/src/modules/Geometry/src/Plane_Method.F90 b/src/modules/Geometry/src/Plane_Method.F90
index 2be4626c7..2cafe3fbe 100644
--- a/src/modules/Geometry/src/Plane_Method.F90
+++ b/src/modules/Geometry/src/Plane_Method.F90
@@ -19,6 +19,10 @@ MODULE Plane_Method
USE GlobalData
IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: plane_normal_line_exp_int_3d
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -54,16 +58,16 @@ MODULE Plane_Method
! Output, real ( kind = 8 ) PINT(3), the coordinates of a
! common point of the plane and line, when IVAL is 1 or 2.
-interface
- module pure subroutine plane_normal_line_exp_int_3d(pp, normal, &
- & p1, p2, ival, pint)
- real(dfp), intent(in) :: pp(3)
- real(dfp), intent(inout) :: normal(3)
- real(dfp), intent(in) :: p1(3)
- real(dfp), intent(in) :: p2(3)
- integer(i4b), intent(out) :: ival
- real(dfp), intent(out) :: pint(3)
- end subroutine
-end interface
+INTERFACE
+ MODULE PURE SUBROUTINE plane_normal_line_exp_int_3d(pp, normal, &
+ p1, p2, ival, pint)
+ REAL(dfp), INTENT(in) :: pp(3)
+ REAL(dfp), INTENT(inout) :: normal(3)
+ REAL(dfp), INTENT(in) :: p1(3)
+ REAL(dfp), INTENT(in) :: p2(3)
+ INTEGER(i4b), INTENT(out) :: ival
+ REAL(dfp), INTENT(out) :: pint(3)
+ END SUBROUTINE
+END INTERFACE
END MODULE Plane_Method
diff --git a/src/modules/Geometry/src/ReferenceElement_Method.F90 b/src/modules/Geometry/src/ReferenceElement_Method.F90
index 8c459eff5..a45ef8b15 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
@@ -36,7 +39,7 @@ MODULE ReferenceElement_Method
PUBLIC :: ReferenceElement_Pointer
PUBLIC :: GetConnectivity
PUBLIC :: ElementType
-PUBLIC :: Elementname
+PUBLIC :: ElementName
PUBLIC :: TotalNodesInElement
PUBLIC :: ElementOrder
PUBLIC :: OPERATOR(.order.)
@@ -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,83 @@ 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
+
+#ifdef MAX_QUADRANGLE_ORDER
+ INTEGER(I4B) :: maxOrder_Quadrangle = MAX_QUADRANGLE_ORDER
+#else
+ INTEGER(I4B) :: maxOrder_Quadrangle = 2_I4B
+#endif
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
+
+!----------------------------------------------------------------------------
+! RefCoord_@GeometryMethods
+!----------------------------------------------------------------------------
+
+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 +322,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(:)
@@ -287,6 +337,32 @@ MODULE PURE SUBROUTINE GetFaceElemType1(elemType, faceElemType, opt, &
END SUBROUTINE GetFaceElemType1
END INTERFACE GetFaceElemType
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-03-11
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType
+ MODULE PURE SUBROUTINE GetFaceElemType2(elemType, localFaceNumber, &
+ faceElemType, opt, tFaceNodes)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! name of element
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Element names of faces
+ INTEGER(I4B), INTENT(OUT) :: tFaceNodes
+ !! Total number of nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType2
+END INTERFACE GetFaceElemType
+
!----------------------------------------------------------------------------
! GetTotalNodes@GeometryMethods
!----------------------------------------------------------------------------
@@ -645,7 +721,7 @@ END FUNCTION refelem_Getnptrs
END INTERFACE GetConnectivity
!----------------------------------------------------------------------------
-! ElementType@ElementnameMethods
+! ElementType@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -660,7 +736,7 @@ END FUNCTION Element_Type
END INTERFACE ElementType
!----------------------------------------------------------------------------
-! ElementType@ElementnameMethods
+! ElementType@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -675,37 +751,37 @@ END FUNCTION Element_Type_obj
END INTERFACE ElementType
!----------------------------------------------------------------------------
-! Elementname@ElementNameMethods
+! ElementName@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 21 May 2022
! summary: Returns element name in character from element number/type
-INTERFACE Elementname
+INTERFACE ElementName
MODULE PURE FUNCTION Element_name(elemType) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: elemType
CHARACTER(:), ALLOCATABLE :: ans
END FUNCTION Element_name
-END INTERFACE Elementname
+END INTERFACE ElementName
!----------------------------------------------------------------------------
-! Elementname@ElementNameMethods
+! ElementName@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 21 May 2022
! summary: Returns element name in character from ReferenceElement
-INTERFACE Elementname
+INTERFACE ElementName
MODULE PURE FUNCTION Element_name_obj(obj) RESULT(ans)
CLASS(ReferenceElement_), INTENT(IN) :: obj
CHARACTER(:), ALLOCATABLE :: ans
END FUNCTION Element_name_obj
-END INTERFACE Elementname
+END INTERFACE ElementName
!----------------------------------------------------------------------------
-! TotalNodesInElement@ElementnameMethods
+! TotalNodesInElement@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -720,7 +796,7 @@ END FUNCTION Total_Nodes_In_Element
END INTERFACE TotalNodesInElement
!----------------------------------------------------------------------------
-! ElementOrder@ElementnameMethods
+! ElementOrder@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -735,7 +811,7 @@ END FUNCTION Element_Order
END INTERFACE ElementOrder
!----------------------------------------------------------------------------
-! ElementOrder@ElementnameMethods
+! ElementOrder@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -754,7 +830,7 @@ END FUNCTION Element_Order_refelem
END INTERFACE OPERATOR(.order.)
!----------------------------------------------------------------------------
-! XiDimension@ElementnameMethods
+! XiDimension@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -770,7 +846,7 @@ END FUNCTION Elem_XiDimension1
END INTERFACE Xidimension
!----------------------------------------------------------------------------
-! Xidimension@ElementnameMethods
+! Xidimension@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1116,7 +1192,7 @@ END FUNCTION isSerendipityElement2
END INTERFACE isSerendipityElement
!----------------------------------------------------------------------------
-! ElementTopology@ElementnameMethods
+! ElementTopology@ElementNameMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1144,7 +1220,7 @@ END FUNCTION refelem_ElementTopology1
END INTERFACE OPERATOR(.topology.)
!----------------------------------------------------------------------------
-! ElementTopology@ElementnameMethods
+! ElementTopology@ElementNameMethods
!----------------------------------------------------------------------------
INTERFACE ElementTopology
@@ -1336,12 +1412,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/GlobalData/src/GlobalData.F90 b/src/modules/GlobalData/src/GlobalData.F90
index caf86f440..6173ba735 100755
--- a/src/modules/GlobalData/src/GlobalData.F90
+++ b/src/modules/GlobalData/src/GlobalData.F90
@@ -15,8 +15,8 @@
! along with this program. If not, see
MODULE GlobalData
-USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: INPUT_UNIT, &
- & OUTPUT_UNIT, ERROR_UNIT
+USE ISO_FORTRAN_ENV, ONLY: INPUT_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/Hexahedron/CMakeLists.txt b/src/modules/Hexahedron/CMakeLists.txt
new file mode 100644
index 000000000..091a2ca74
--- /dev/null
+++ b/src/modules/Hexahedron/CMakeLists.txt
@@ -0,0 +1,21 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME} PRIVATE ${src_path}/ReferenceHexahedron_Method.F90
+ ${src_path}/HexahedronInterpolationUtility.F90)
diff --git a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90 b/src/modules/Hexahedron/src/HexahedronInterpolationUtility.F90
similarity index 67%
rename from src/modules/Polynomial/src/HexahedronInterpolationUtility.F90
rename to src/modules/Hexahedron/src/HexahedronInterpolationUtility.F90
index fef9276e3..cc4adabad 100644
--- a/src/modules/Polynomial/src/HexahedronInterpolationUtility.F90
+++ b/src/modules/Hexahedron/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/Geometry/src/ReferenceHexahedron_Method.F90 b/src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90
similarity index 91%
rename from src/modules/Geometry/src/ReferenceHexahedron_Method.F90
rename to src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90
index af249edaa..47774757c 100644
--- a/src/modules/Geometry/src/ReferenceHexahedron_Method.F90
+++ b/src/modules/Hexahedron/src/ReferenceHexahedron_Method.F90
@@ -355,9 +355,12 @@ END FUNCTION RefHexahedronCoord
! date: 2024-03-11
! summary: Returns the element type of each face
-INTERFACE
- MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron(faceElemType, opt, &
- & tFaceNodes, elemType)
+INTERFACE GetFaceElemType_Hexahedron
+ MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron1(elemType, faceElemType, &
+ tFaceNodes, opt)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
+ !! This denotes the element type of Hexahedron
+ !! Default value is Hexahedron6
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
!! Face element type
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:)
@@ -366,10 +369,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron(faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
- !! This denotes the element type of Hexahedron
- !! Default value is Hexahedron6
- END SUBROUTINE GetFaceElemType_Hexahedron
-END INTERFACE
+ END SUBROUTINE GetFaceElemType_Hexahedron1
+END INTERFACE GetFaceElemType_Hexahedron
+
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-03-11
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Hexahedron
+ MODULE PURE SUBROUTINE GetFaceElemType_Hexahedron2( &
+ elemType, localFaceNumber, faceElemType, tFaceNodes, opt)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type of Hexahedron
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Face element type
+ INTEGER(I4B), INTENT(OUT) :: tFaceNodes
+ !! total nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Hexahedron2
+END INTERFACE GetFaceElemType_Hexahedron
END MODULE ReferenceHexahedron_Method
diff --git a/src/modules/IntVector/src/IntVector_ConstructorMethod.F90 b/src/modules/IntVector/src/IntVector_ConstructorMethod.F90
index 37c0ded01..2b66681e4 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
@@ -31,6 +31,8 @@ MODULE IntVector_ConstructorMethod
PUBLIC :: IntVector
PUBLIC :: IntVector_Pointer
PUBLIC :: Convert
+PUBLIC :: Copy
+PUBLIC :: Copy_
!----------------------------------------------------------------------------
! Shape@Constructor
@@ -41,10 +43,10 @@ MODULE IntVector_ConstructorMethod
! summary: Returns shape of the vector
INTERFACE Shape
- MODULE PURE FUNCTION intVec_shape(obj) RESULT(Ans)
- CLASS(IntVector_), INTENT(IN) :: obj
- INTEGER(I4B) :: Ans(1)
- END FUNCTION intVec_shape
+ MODULE PURE FUNCTION obj_shape(obj) RESULT(ans)
+ TYPE(IntVector_), INTENT(IN) :: obj
+ INTEGER(I4B) :: ans(1)
+ END FUNCTION obj_shape
END INTERFACE Shape
!----------------------------------------------------------------------------
@@ -56,11 +58,11 @@ END FUNCTION intVec_shape
! summary: Returns size of the vector
INTERFACE Size
- MODULE PURE FUNCTION intVec_Size(obj, Dims) RESULT(Ans)
+ MODULE PURE FUNCTION obj_Size(obj, dims) RESULT(ans)
TYPE(IntVector_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN), OPTIONAL :: Dims
- INTEGER(I4B) :: Ans
- END FUNCTION intVec_Size
+ INTEGER(I4B), INTENT(IN), OPTIONAL :: dims
+ INTEGER(I4B) :: ans
+ END FUNCTION obj_Size
END INTERFACE Size
!----------------------------------------------------------------------------
@@ -76,10 +78,10 @@ END FUNCTION intVec_Size
! This function returns the total dimension (or rank) of an array,
INTERFACE GetTotalDimension
- MODULE PURE FUNCTION IntVec_getTotalDimension(obj) RESULT(Ans)
+ MODULE PURE FUNCTION obj_getTotalDimension(obj) RESULT(ans)
TYPE(IntVector_), INTENT(IN) :: obj
INTEGER(I4B) :: ans
- END FUNCTION IntVec_getTotalDimension
+ END FUNCTION obj_getTotalDimension
END INTERFACE GetTotalDimension
!----------------------------------------------------------------------------
@@ -91,10 +93,10 @@ END FUNCTION IntVec_getTotalDimension
! summary: Allocate memory for the vector
INTERFACE ALLOCATE
- MODULE PURE SUBROUTINE intVec_AllocateData(obj, Dims)
- CLASS(IntVector_), INTENT(INOUT) :: obj
- INTEGER(I4B), INTENT(IN) :: Dims
- END SUBROUTINE intVec_AllocateData
+ MODULE PURE SUBROUTINE obj_AllocateData(obj, dims)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
+ INTEGER(I4B), INTENT(IN) :: dims
+ END SUBROUTINE obj_AllocateData
END INTERFACE ALLOCATE
!----------------------------------------------------------------------------
@@ -106,10 +108,10 @@ END SUBROUTINE intVec_AllocateData
! summary: Allocate memory for the vector
INTERFACE Reallocate
- MODULE PURE SUBROUTINE intVec_Reallocate(obj, row)
+ MODULE PURE SUBROUTINE obj_Reallocate(obj, row)
TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:)
INTEGER(I4B), INTENT(IN) :: row
- END SUBROUTINE intVec_Reallocate
+ END SUBROUTINE obj_Reallocate
END INTERFACE Reallocate
!----------------------------------------------------------------------------
@@ -121,9 +123,9 @@ END SUBROUTINE intVec_Reallocate
! summary: Deallocate memory occupied by IntVector
INTERFACE DEALLOCATE
- MODULE PURE SUBROUTINE intVec_Deallocate(obj)
- CLASS(IntVector_), INTENT(INOUT) :: obj
- END SUBROUTINE intVec_Deallocate
+ MODULE PURE SUBROUTINE obj_Deallocate(obj)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
+ END SUBROUTINE obj_Deallocate
END INTERFACE DEALLOCATE
!----------------------------------------------------------------------------
@@ -140,10 +142,10 @@ END SUBROUTINE intVec_Deallocate
! Only the size of intvector is set.
INTERFACE Initiate
- MODULE PURE SUBROUTINE intVec_initiate1(obj, tSize)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate1(obj, tSize)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: tSize
- END SUBROUTINE intVec_initiate1
+ END SUBROUTINE obj_initiate1
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -155,10 +157,10 @@ END SUBROUTINE intVec_initiate1
! summary: This routine initiates the vector of [[IntVector_]]
INTERFACE Initiate
- MODULE PURE SUBROUTINE intVec_initiate2(obj, tSize)
+ MODULE PURE SUBROUTINE obj_initiate2(obj, tSize)
TYPE(IntVector_), ALLOCATABLE, INTENT(INOUT) :: obj(:)
INTEGER(I4B), INTENT(IN) :: tSize(:)
- END SUBROUTINE intVec_initiate2
+ END SUBROUTINE obj_initiate2
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -171,10 +173,10 @@ END SUBROUTINE intVec_initiate2
! summary: Initiates an instance on [[IntVector_]] with lower & upper bounds
INTERFACE Initiate
- MODULE PURE SUBROUTINE intVec_initiate3(obj, a, b)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate3(obj, a, b)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: a, b
- END SUBROUTINE intVec_initiate3
+ END SUBROUTINE obj_initiate3
END INTERFACE Initiate
!----------------------------------------------------------------------------
@@ -193,30 +195,30 @@ END SUBROUTINE intVec_initiate3
! This routine also define an assignment operator, obj=val
INTERFACE Initiate
- MODULE PURE SUBROUTINE intVec_initiate4a(obj, val)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate4a(obj, val)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
INTEGER(INT8), INTENT(IN) :: val(:)
- END SUBROUTINE intVec_initiate4a
+ END SUBROUTINE obj_initiate4a
!!
- MODULE PURE SUBROUTINE intVec_initiate4b(obj, val)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate4b(obj, val)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
INTEGER(INT16), INTENT(IN) :: val(:)
- END SUBROUTINE intVec_initiate4b
+ END SUBROUTINE obj_initiate4b
!!
- MODULE PURE SUBROUTINE intVec_initiate4c(obj, val)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate4c(obj, val)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
INTEGER(INT32), INTENT(IN) :: val(:)
- END SUBROUTINE intVec_initiate4c
+ END SUBROUTINE obj_initiate4c
!!
- MODULE PURE SUBROUTINE intVec_initiate4d(obj, val)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate4d(obj, val)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
INTEGER(INT64), INTENT(IN) :: val(:)
- END SUBROUTINE intVec_initiate4d
+ END SUBROUTINE obj_initiate4d
END INTERFACE Initiate
INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE intVec_initiate4a, intVec_initiate4b, &
- & intVec_initiate4c, intVec_initiate4d
+ MODULE PROCEDURE obj_initiate4a, obj_initiate4b, &
+ obj_initiate4c, obj_initiate4d
END INTERFACE ASSIGNMENT(=)
!----------------------------------------------------------------------------
@@ -235,21 +237,44 @@ END SUBROUTINE intVec_initiate4d
! obj=val
INTERFACE Initiate
- MODULE PURE SUBROUTINE intVec_initiate5a(obj, val)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate5a(obj, val)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
REAL(REAL32), INTENT(IN) :: val(:)
- END SUBROUTINE intVec_initiate5a
+ END SUBROUTINE obj_initiate5a
!!
- MODULE PURE SUBROUTINE intVec_initiate5b(obj, val)
- CLASS(IntVector_), INTENT(INOUT) :: obj
+ MODULE PURE SUBROUTINE obj_initiate5b(obj, val)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
REAL(REAL64), INTENT(IN) :: val(:)
- END SUBROUTINE intVec_initiate5b
+ END SUBROUTINE obj_initiate5b
END INTERFACE Initiate
INTERFACE ASSIGNMENT(=)
- MODULE PROCEDURE intVec_initiate5a, intVec_initiate5b
+ MODULE PROCEDURE obj_initiate5a, obj_initiate5b
END INTERFACE ASSIGNMENT(=)
+!----------------------------------------------------------------------------
+! Initiate@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-07-25
+! summary: Initiate an instance of IntVector by copying data from other
+
+INTERFACE Initiate
+ MODULE PURE SUBROUTINE obj_initiate6(obj, obj2)
+ TYPE(IntVector_), INTENT(INOUT) :: obj
+ TYPE(IntVector_), INTENT(IN) :: obj2
+ END SUBROUTINE obj_initiate6
+END INTERFACE Initiate
+
+INTERFACE ASSIGNMENT(=)
+ MODULE PROCEDURE obj_initiate6
+END INTERFACE ASSIGNMENT(=)
+
+INTERFACE COPY
+ MODULE PROCEDURE obj_initiate6
+END INTERFACE COPY
+
!----------------------------------------------------------------------------
! IntVector@Constructor
!----------------------------------------------------------------------------
@@ -260,10 +285,10 @@ END SUBROUTINE intVec_initiate5b
! summary: IntVector returns an instance of [[IntVector_]] of given size
INTERFACE IntVector
- MODULE PURE FUNCTION intVec_Constructor1(tSize) RESULT(obj)
+ MODULE PURE FUNCTION obj_Constructor1(tSize) RESULT(obj)
TYPE(IntVector_) :: obj
INTEGER(I4B), INTENT(IN) :: tSize
- END FUNCTION intVec_Constructor1
+ END FUNCTION obj_Constructor1
END INTERFACE IntVector
!----------------------------------------------------------------------------
@@ -276,10 +301,10 @@ END FUNCTION intVec_Constructor1
! summary: Convert a integer vector into [[IntVector_]]
INTERFACE IntVector
- MODULE PURE FUNCTION intVec_Constructor2(Val) RESULT(obj)
+ MODULE PURE FUNCTION obj_Constructor2(Val) RESULT(obj)
TYPE(IntVector_) :: obj
INTEGER(I4B), INTENT(IN) :: Val(:)
- END FUNCTION intVec_Constructor2
+ END FUNCTION obj_Constructor2
END INTERFACE IntVector
!----------------------------------------------------------------------------
@@ -295,10 +320,10 @@ END FUNCTION intVec_Constructor2
! Real32, Real64
!
INTERFACE IntVector
- MODULE PURE FUNCTION intVec_Constructor3(Val) RESULT(obj)
+ MODULE PURE FUNCTION obj_Constructor3(Val) RESULT(obj)
TYPE(IntVector_) :: obj
REAL(DFP), INTENT(IN) :: Val(:)
- END FUNCTION intVec_Constructor3
+ END FUNCTION obj_Constructor3
END INTERFACE IntVector
!----------------------------------------------------------------------------
@@ -311,10 +336,10 @@ END FUNCTION intVec_Constructor3
! summary: Returns the pointer to an instance of [[IntVector_]] of tsize
INTERFACE IntVector_Pointer
- MODULE PURE FUNCTION intVec_Constructor_1(tSize) RESULT(obj)
- CLASS(IntVector_), POINTER :: obj
+ MODULE PURE FUNCTION obj_Constructor_1(tSize) RESULT(obj)
+ TYPE(IntVector_), POINTER :: obj
INTEGER(I4B), INTENT(IN) :: tSize
- END FUNCTION intVec_Constructor_1
+ END FUNCTION obj_Constructor_1
END INTERFACE IntVector_Pointer
!----------------------------------------------------------------------------
@@ -327,10 +352,10 @@ END FUNCTION intVec_Constructor_1
! summary: Converts integer vector into [[intvector_]] and returns the pointer
INTERFACE IntVector_Pointer
- MODULE PURE FUNCTION intVec_Constructor_2(Val) RESULT(obj)
- CLASS(IntVector_), POINTER :: obj
+ MODULE PURE FUNCTION obj_Constructor_2(Val) RESULT(obj)
+ TYPE(IntVector_), POINTER :: obj
INTEGER(I4B), INTENT(IN) :: Val(:)
- END FUNCTION intVec_Constructor_2
+ END FUNCTION obj_Constructor_2
END INTERFACE IntVector_Pointer
!----------------------------------------------------------------------------
@@ -343,10 +368,10 @@ END FUNCTION intVec_Constructor_2
! summary: Converts real vector into [[intvector_]] and returns the pointer
INTERFACE IntVector_Pointer
- MODULE PURE FUNCTION intVec_Constructor_3(Val) RESULT(obj)
- CLASS(IntVector_), POINTER :: obj
+ MODULE PURE FUNCTION obj_Constructor_3(Val) RESULT(obj)
+ TYPE(IntVector_), POINTER :: obj
REAL(DFP), INTENT(IN) :: Val(:)
- END FUNCTION intVec_Constructor_3
+ END FUNCTION obj_Constructor_3
END INTERFACE IntVector_Pointer
!----------------------------------------------------------------------------
@@ -354,10 +379,10 @@ END FUNCTION intVec_Constructor_3
!----------------------------------------------------------------------------
INTERFACE ASSIGNMENT(=)
- MODULE PURE SUBROUTINE IntVec_assign_a(Val, obj)
+ MODULE PURE SUBROUTINE obj_assign_a(Val, obj)
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: Val(:)
- CLASS(IntVector_), INTENT(IN) :: obj
- END SUBROUTINE IntVec_assign_a
+ TYPE(IntVector_), INTENT(IN) :: obj
+ END SUBROUTINE obj_assign_a
END INTERFACE ASSIGNMENT(=)
!----------------------------------------------------------------------------
@@ -366,9 +391,126 @@ END SUBROUTINE IntVec_assign_a
INTERFACE Convert
MODULE PURE SUBROUTINE obj_convert_int(From, To)
- CLASS(IntVector_), INTENT(IN) :: From
+ TYPE(IntVector_), INTENT(IN) :: From
INTEGER(I4B), ALLOCATABLE, INTENT(INOUT) :: To(:)
END SUBROUTINE obj_convert_int
END INTERFACE Convert
+!----------------------------------------------------------------------------
+! Copy@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-22
+! summary: Copy y into x, x will be reallocated
+!
+!# Introduction
+!
+! Get the size of y and reallocate x to the same size.
+! If x is already allocated, it will be reallocated to the size of y.
+
+INTERFACE Copy
+ MODULE PURE SUBROUTINE obj_Copy_Int8(x, y)
+ INTEGER(INT8), INTENT(INOUT), ALLOCATABLE :: x(:)
+ INTEGER(INT8), INTENT(IN) :: y(:)
+ END SUBROUTINE obj_Copy_Int8
+END INTERFACE Copy
+
+!----------------------------------------------------------------------------
+! Copy@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-22
+! summary: Copy y into x, x will be reallocated
+!
+!# Introduction
+!
+! Get the size of y and reallocate x to the same size.
+! If x is already allocated, it will be reallocated to the size of y.
+
+INTERFACE Copy
+ MODULE PURE SUBROUTINE obj_Copy_Int16(x, y)
+ INTEGER(INT16), INTENT(INOUT), ALLOCATABLE :: x(:)
+ INTEGER(INT16), INTENT(IN) :: y(:)
+ END SUBROUTINE obj_Copy_Int16
+END INTERFACE Copy
+
+!----------------------------------------------------------------------------
+! Copy@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-22
+! summary: Copy y into x, x will be reallocated
+!
+! Introduction
+!
+! Get the size of y and reallocate x to the same size.
+! If x is already allocated, it will be reallocated to the size of y.
+
+INTERFACE Copy
+ MODULE PURE SUBROUTINE obj_Copy_Int32(x, y)
+ INTEGER(INT32), INTENT(INOUT), ALLOCATABLE :: x(:)
+ INTEGER(INT32), INTENT(IN) :: y(:)
+ END SUBROUTINE obj_Copy_Int32
+END INTERFACE Copy
+
+!----------------------------------------------------------------------------
+! Copy@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-22
+! summary: Copy y into x, x will be reallocated
+!
+!# Introduction
+!
+! Get the size of y and reallocate x to the same size.
+! If x is already allocated, it will be reallocated to the size of y.
+
+INTERFACE Copy
+ MODULE PURE SUBROUTINE obj_Copy_Int64(x, y)
+ INTEGER(INT64), INTENT(INOUT), ALLOCATABLE :: x(:)
+ INTEGER(INT64), INTENT(IN) :: y(:)
+ END SUBROUTINE obj_Copy_Int64
+END INTERFACE Copy
+
+!----------------------------------------------------------------------------
+! Copy@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-22
+! summary: Copy portion of y into x
+
+INTERFACE Copy_
+ MODULE PURE SUBROUTINE obj_Copy1_(x, x_start, y, y_start, y_end)
+ INTEGER(I4B), INTENT(INOUT) :: x(:)
+ !! x vector should be allocated
+ INTEGER(I4B), INTENT(IN) :: y(:)
+ INTEGER(I4B), INTENT(IN) :: x_start
+ INTEGER(I4B), INTENT(IN) :: y_start, y_end
+ END SUBROUTINE obj_Copy1_
+END INTERFACE Copy_
+
+!----------------------------------------------------------------------------
+! Copy@Constructor
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-22
+! summary: Copy y into x
+
+INTERFACE Copy_
+ MODULE PURE SUBROUTINE obj_Copy2_(x, y)
+ INTEGER(I4B), INTENT(INOUT) :: x(:)
+ INTEGER(I4B), INTENT(IN) :: y(:)
+ END SUBROUTINE obj_Copy2_
+END INTERFACE Copy_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
END MODULE IntVector_ConstructorMethod
diff --git a/src/modules/IntVector/src/IntVector_GetMethod.F90 b/src/modules/IntVector/src/IntVector_GetMethod.F90
index f04c4768c..91d3c2646 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,22 +388,37 @@ 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
+!----------------------------------------------------------------------------
+! GetPointers@getMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-05-29
+! summary: Get the pointer to the raw data of the IntVector instance.
+
+INTERFACE GetPointer
+ MODULE FUNCTION intVec_getPointer_3(obj) RESULT(val)
+ CLASS(IntVector_), INTENT(IN), TARGET :: obj
+ INTEGER(I4B), POINTER :: val(:)
+ END FUNCTION intVec_getPointer_3
+END INTERFACE GetPointer
+
!----------------------------------------------------------------------------
! getIndex@getMethod
!----------------------------------------------------------------------------
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 +427,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/Lapack_Method.F90 b/src/modules/Lapack/src/Lapack_Method.F90
index bb0647fb4..ebfa0abe4 100644
--- a/src/modules/Lapack/src/Lapack_Method.F90
+++ b/src/modules/Lapack/src/Lapack_Method.F90
@@ -18,4 +18,4 @@
MODULE Lapack_Method
USE GE_Lapack_Method
USE Sym_Lapack_Method
-END MODULE Lapack_Method
\ No newline at end of file
+END MODULE Lapack_Method
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/Line/CMakeLists.txt b/src/modules/Line/CMakeLists.txt
new file mode 100644
index 000000000..50dd294e7
--- /dev/null
+++ b/src/modules/Line/CMakeLists.txt
@@ -0,0 +1,23 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/Line_Method.F90
+ ${src_path}/ReferenceLine_Method.F90
+ ${src_path}/LineInterpolationUtility.F90)
diff --git a/src/modules/Line/src/LineInterpolationUtility.F90 b/src/modules/Line/src/LineInterpolationUtility.F90
new file mode 100644
index 000000000..5c63d33ab
--- /dev/null
+++ b/src/modules/Line/src/LineInterpolationUtility.F90
@@ -0,0 +1,1983 @@
+! 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 LineInterpolationUtility
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE String_Class, ONLY: String
+IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: LagrangeDegree_Line
+PUBLIC :: LagrangeDOF_Point
+PUBLIC :: LagrangeDOF_Line
+PUBLIC :: LagrangeInDOF_Line
+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 :: HeirarchicalBasis_Line_
+
+PUBLIC :: HeirarchicalBasisGradient_Line
+PUBLIC :: HeirarchicalBasisGradient_Line_
+
+PUBLIC :: OrthogonalBasis_Line
+PUBLIC :: OrthogonalBasis_Line_
+PUBLIC :: OrthogonalBasisGradient_Line
+PUBLIC :: OrthogonalBasisGradient_Line_
+
+!----------------------------------------------------------------------------
+! RefElemDomain_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-03
+! summary: Returns the coordinate of reference element
+
+INTERFACE
+ MODULE FUNCTION RefElemDomain_Line(baseContinuity, baseInterpol) &
+ & RESULT(ans)
+ 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_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! QuadratureNumber_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-20
+! summary: REturns the number of quadrature points necessary for given order
+
+INTERFACE
+ MODULE PURE FUNCTION QuadratureNumber_Line(order, quadType) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B), INTENT(IN) :: quadType
+ INTEGER(I4B) :: ans
+ END FUNCTION QuadratureNumber_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! ToVEFC_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-20
+! summary: Change layour of points on line
+
+INTERFACE
+ MODULE PURE SUBROUTINE ToVEFC_Line(pt)
+ REAL(DFP), INTENT(INOUT) :: pt(:)
+ END SUBROUTINE ToVEFC_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Returns the degree of monomials for Lagrange polynomials
+
+INTERFACE
+ MODULE PURE FUNCTION LagrangeDegree_Line(order) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B), ALLOCATABLE :: ans(:, :)
+ END FUNCTION LagrangeDegree_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! LagrangeDOF_Point
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns the total number of degree of freedom for a
+! lagrange polynomial on a point of Line
+
+INTERFACE
+ MODULE PURE FUNCTION LagrangeDOF_Point(order) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B) :: ans
+ END FUNCTION LagrangeDOF_Point
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! GetDOF_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns the total number of degree of freedom for a
+! lagrange polynomial on Line
+
+INTERFACE
+ MODULE PURE FUNCTION LagrangeDOF_Line(order) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B) :: ans
+ END FUNCTION LagrangeDOF_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns the total number of degree of freedom for a
+! lagrange polynomial on an edge of a Line
+!
+!# Introduction
+!
+!- Returns the total number of degree of freedom for a
+! lagrange polynomial on an edge of a Line
+!- These dof are strictly inside the line
+
+INTERFACE
+ MODULE PURE FUNCTION LagrangeInDOF_Line(order) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B) :: ans
+ END FUNCTION LagrangeInDOF_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! GetTotalDOF_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns the total number of degree of freedom for a
+! lagrange polynomial on Line
+
+INTERFACE
+ 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
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns the total number of degree of freedom for a
+! lagrange polynomial on an edge of a Line
+!
+!# Introduction
+!
+!- Returns the total number of degree of freedom for a
+! lagrange polynomial on an edge of a Line
+!- These dof are strictly inside the line
+
+INTERFACE
+ MODULE PURE FUNCTION GetTotalInDOF_Line(order, baseContinuity, &
+ baseInterpolation) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ CHARACTER(*), INTENT(IN) :: baseContinuity
+ CHARACTER(*), INTENT(IN) :: baseInterpolation
+ INTEGER(I4B) :: ans
+ END FUNCTION GetTotalInDOF_Line
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance internal points on edge
+!
+!# Introduction
+!
+!- This function returns the equidistance points on edge in 1D
+!- All points are inside the interval
+!- Points are in increasing order
+
+INTERFACE EquidistanceInPoint_Line
+ MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(IN) :: xij(2)
+ !! coordinates of point 1 and point 2
+ REAL(DFP), ALLOCATABLE :: 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance points on edge
+!
+!# Introduction
+!
+!- This function returns the equidistance points on edge in 1D, 2D, 3D
+!- The end points are specified by `xij(1:nsd, 1)` and `xij(1:nsd, 2)`
+!
+!- All points are inside the interval
+!- The number of space components in `ans` is nsd if xij present
+!- Otherwise, the number of space components in `ans` is 1.
+
+INTERFACE EquidistanceInPoint_Line
+ MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans)
+ 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), 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.
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance points on edge
+!
+!# Introduction
+!
+!- This function returns the equidistance points on edge
+!- Points are in "VEFC" format, which means `xij(1,1:2)` are end points
+
+INTERFACE EquidistancePoint_Line
+ MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) &
+ & RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), INTENT(IN) :: xij(2)
+ !! coorindates of point 1 and point 2
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ !! equidistance points
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance points on line
+!
+!# Introduction
+!
+!- This function returns the equidistance points on line
+!- All points are inside the interval
+
+INTERFACE EquidistancePoint_Line
+ MODULE PURE FUNCTION EquidistancePoint_Line2(order, xij) &
+ & RESULT(ans)
+ 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), ALLOCATABLE :: 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.
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Aug 2022
+! summary: Returns the interpolation point
+!
+!# Introduction
+!
+!- This routine returns the interplation points on line
+!- `xij` contains nodal coordinates of line in xij format.
+!- SIZE(xij,1) = nsd, and SIZE(xij,2)=2
+!- If xij is absent then [-1,1] is used
+!- `ipType` is interpolation point type, it can take following values
+!- `Equidistance`, uniformly/evenly distributed points
+!- `GaussLegendre`, Zeros of Legendre polynomials, all nodes are strictly
+! inside the domain.
+!- `GaussLegendreLobatto` or `GaussLobatto` are zeros of Lobatto polynomials
+! they always contains boundary points
+!- `GaussChebyshev` Zeros of Chebyshev polynomials of first kind, all
+! nodes are internal
+!- `GaussChebyshevLobatto` they contains boundary points
+!- `GaussJacobi` and `GaussJacobiLobatto`
+!
+!- `layout` specifies the arrangement of points. Following options are
+! possible:
+!
+!- `layout=VEFC` vertex, edge, face, cell, in this case first two points are
+! boundary points, remaining (from 3 to n) are internal points in
+! increasing order.
+!
+!- `layout=INCREASING` points are arranged in increasing order
+
+INTERFACE InterpolationPoint_Line
+ MODULE FUNCTION InterpolationPoint_Line1( &
+ order, ipType, layout, xij, alpha, beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of interpolation
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Interpolation point type
+ !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev,
+ !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto
+ 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
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! interpolation points in xij format
+ !! size(ans,1) = 1
+ !! size(ans,2) = order+1
+ END FUNCTION InterpolationPoint_Line1
+END INTERFACE InterpolationPoint_Line
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Line_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-06-25
+! summary: Interpolation without allocation
+!
+!# Introduction
+!
+! ipType can take value from TypeInterpolationOpt
+
+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
+ 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" or "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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Aug 2022
+! summary: Returns the interpolation point
+
+INTERFACE InterpolationPoint_Line
+ MODULE FUNCTION InterpolationPoint_Line2( &
+ order, ipType, xij, layout, alpha, beta, lambda) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of interpolation
+ INTEGER(I4B), INTENT(IN) :: ipType
+ !! Interpolation point type
+ 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
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ !! one dimensional interpolation point
+ 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
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeCoeff_Line
+ MODULE FUNCTION LagrangeCoeff_Line1(order, i, xij) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial, it should be SIZE(xij,2)-1
+ INTEGER(I4B), INTENT(IN) :: i
+ !! ith coefficients for lagrange polynomial
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2) = order+1
+ REAL(DFP) :: ans(order + 1)
+ !! coefficients
+ END FUNCTION LagrangeCoeff_Line1
+END INTERFACE LagrangeCoeff_Line
+
+!----------------------------------------------------------------------------
+! 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
+ !! order of polynomial, it should be SIZE(v,2)-1
+ INTEGER(I4B), INTENT(IN) :: i
+ !! coefficient for ith lagrange polynomial
+ REAL(DFP), INTENT(IN) :: v(:, :)
+ !! vandermonde matrix size should be (order+1,order+1)
+ LOGICAL(LGT), INTENT(IN) :: isVandermonde
+ !! This is just to resolve interface issue
+ REAL(DFP) :: ans(order + 1)
+ !! coefficients
+ END FUNCTION LagrangeCoeff_Line2
+END INTERFACE LagrangeCoeff_Line
+
+!----------------------------------------------------------------------------
+! 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
+ !! order of polynomial, it should be SIZE(x,2)-1
+ INTEGER(I4B), INTENT(IN) :: i
+ !! ith coefficients for lagrange polynomial
+ REAL(DFP), INTENT(INOUT) :: v(:, :)
+ !! LU decomposition of vandermonde matrix
+ INTEGER(I4B), INTENT(IN) :: ipiv(:)
+ !! inverse pivoting mapping, compes from LU decomposition
+ REAL(DFP) :: ans(order + 1)
+ !! coefficients
+ END FUNCTION LagrangeCoeff_Line3
+END INTERFACE LagrangeCoeff_Line
+
+!----------------------------------------------------------------------------
+! 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
+ !! order of polynomial, it should be SIZE(xij,2)-1
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in xij format, size(xij,2) = order+1
+ REAL(DFP) :: ans(order + 1, order + 1)
+ !! coefficients
+ !! jth column of ans corresponds to the coeff of lagrange polynomial
+ !! at the jth point
+ 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)
+ 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) :: ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ !! jth column of ans corresponds to the coeff of lagrange polynomial
+ !! at the jth point
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate Lagrange polynomials of order n at single points
+
+INTERFACE LagrangeEvalAll_Line
+ MODULE FUNCTION LagrangeEvalAll_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
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: xij(:, :)
+ !! interpolation points
+ 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
+ REAL(DFP) :: ans(SIZE(xij, 2))
+ !! Value of n+1 Lagrange polynomials at point x
+ END FUNCTION LagrangeEvalAll_Line1
+END INTERFACE LagrangeEvalAll_Line
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-27
+! summary: Lagrange evall all at a single point
+
+INTERFACE
+ 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
+
+INTERFACE LagrangeEvalAll_Line_
+ MODULE PROCEDURE LagrangeEvalAll_Line1_
+END INTERFACE LagrangeEvalAll_Line_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! 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)
+ 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), 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
+ REAL(DFP) :: 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
+ END FUNCTION LagrangeEvalAll_Line2
+END INTERFACE LagrangeEvalAll_Line
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-27
+! summary: Lagrange eval all at several points without allocation
+
+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_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-27
+! summary: Lagrange eval all at several points without allocation
+
+INTERFACE
+ MODULE SUBROUTINE LagrangeEvalAll_Line3_( &
+ order, x, xij, ans, nrow, ncol, coeff, xx, 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, ncol
+ 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
+ !! rows of xij = nsd
+ !! cols of xij = ncol
+ 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
+ !! nrow = size(x, 2), number of points of evaluation
+ !! ncol = size(xij, 2), number of interpolation points
+ REAL(DFP), INTENT(INOUT) :: coeff(:, :), xx(:, :)
+ !! coefficient of Lagrange polynomials
+ !! The size should be at least ncol by ncol
+ !! The size of xx should be at least nrow by ncol
+ !! It contains the evaluation of basis functions on x
+ !! Size of xx is nrow by ncol
+ LOGICAL(LGT) :: 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_Line3_
+END INTERFACE
+
+INTERFACE LagrangeEvalAll_Line_
+ MODULE PROCEDURE LagrangeEvalAll_Line3_
+END INTERFACE LagrangeEvalAll_Line_
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! 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)
+ 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), 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
+ REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 1)
+ !! 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
+ END FUNCTION LagrangeGradientEvalAll_Line1
+END INTERFACE LagrangeGradientEvalAll_Line
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Line_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Line1_( &
+ 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(:, :, :)
+ !! 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
+
+INTERFACE LagrangeGradientEvalAll_Line_
+ MODULE PROCEDURE LagrangeGradientEvalAll_Line1_
+END INTERFACE LagrangeGradientEvalAll_Line_
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Line_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE SUBROUTINE LagrangeGradientEvalAll_Line2_( &
+ order, x, xij, ans, dim1, dim2, dim3, coeff, xx, 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(:, :, :)
+ !! 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), INTENT(INOUT) :: coeff(:, :)
+ !! coefficient of Lagrange polynomials
+ !! shape nrow = size(xij, 2), ncol = size(xij, 2)
+ REAL(DFP), INTENT(INOUT) :: xx(:, :)
+ !! nrow: size(x, 2), ncol: order + 1
+ LOGICAL(LGT) :: 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), 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_Line2_
+END INTERFACE
+
+INTERFACE LagrangeGradientEvalAll_Line_
+ MODULE PROCEDURE LagrangeGradientEvalAll_Line2_
+END INTERFACE LagrangeGradientEvalAll_Line_
+
+!----------------------------------------------------------------------------
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate basis functions of order upto n
+!
+!# Introduction
+!
+! BasisType can take following values
+! Monomial
+! Jacobi
+! Ultraspherical
+! Legendre
+! Chebyshev
+! Lobatto
+! UnscaledLobatto
+
+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
+ !! BasisType
+ 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) :: ans(order + 1)
+ !! Value of n+1 polynomials at point x
+ 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
+ !! BasisType
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate basis functions of order upto n
+
+INTERFACE BasisEvalAll_Line
+ 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(:)
+ !! point of evaluation
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! UNIT, BIUNIT
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
+ !! BasisType
+ 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) :: 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
+ 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
+ !! basis type
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate basis functions of order upto n
+
+INTERFACE OrthogonalBasis_Line
+ 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
+ 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) :: ans(SIZE(xij, 2), 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
+ END FUNCTION OrthogonalBasis_Line1
+END INTERFACE OrthogonalBasis_Line
+
+!----------------------------------------------------------------------------
+! OrthogonalBasis_Line_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE OrthogonalBasis_Line_
+ MODULE PROCEDURE OrthogonalBasis_Line1_
+END INTERFACE OrthogonalBasis_Line_
+
+!----------------------------------------------------------------------------
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate basis functions of order upto n
+
+INTERFACE
+ 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(:, :)
+ !! point of evaluation
+ !! Number of rows in xij is 1
+ CHARACTER(*), INTENT(IN) :: refLine
+ !! UNIT ! BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ ! basisType
+ 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) :: 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
+ END FUNCTION OrthogonalBasisGradient_Line1
+END INTERFACE
+
+INTERFACE OrthogonalBasisGradient_Line
+ MODULE PROCEDURE OrthogonalBasisGradient_Line1
+END INTERFACE OrthogonalBasisGradient_Line
+
+!----------------------------------------------------------------------------
+! OrthgonalBasisGradient_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-09-10
+! summary: gradient of orthogonal basis without allocation
+!
+!# Introduction
+!
+! refline: Unit, Biunit
+! basisType: Jacobi, Ultraspherical, Legendre, Chebyshev, Lobatto,
+! UnscaledLobatto
+
+INTERFACE
+ 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
+ !! reference line element: UNIT, BIUNIT
+ INTEGER(I4B), INTENT(IN) :: basisType
+ !! basisType
+ 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
+
+INTERFACE OrthogonalBasisGradient_Line_
+ MODULE PROCEDURE OrthogonalBasisGradient_Line1_
+END INTERFACE OrthogonalBasisGradient_Line_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Evaluate all modal basis (heirarchical polynomial) on Line
+
+INTERFACE
+ MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans)
+ 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) :: ans(SIZE(xij, 2), order + 1)
+ !! Hierarchical basis
+ END FUNCTION HeirarchicalBasis_Line1
+END INTERFACE
+
+INTERFACE HeirarchicalBasis_Line
+ MODULE PROCEDURE HeirarchicalBasis_Line1
+END INTERFACE HeirarchicalBasis_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE HeirarchicalBasis_Line_
+ MODULE PROCEDURE HeirarchicalBasis_Line1_
+END INTERFACE HeirarchicalBasis_Line_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE HeirarchicalBasis_Line_
+ MODULE PROCEDURE HeirarchicalBasis_Line2_
+END INTERFACE HeirarchicalBasis_Line_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Eval gradient of all modal basis (heirarchical polynomial) on Line
+
+INTERFACE
+ MODULE FUNCTION HeirarchicalGradientBasis_Line1(order, xij, refLine) &
+ 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.
+ REAL(DFP) :: ans(SIZE(xij, 2), order + 1, 1)
+ !! Gradient of Hierarchical basis
+ END FUNCTION HeirarchicalGradientBasis_Line1
+END INTERFACE
+
+INTERFACE HeirarchicalBasisGradient_Line
+ MODULE PROCEDURE HeirarchicalGradientBasis_Line1
+END INTERFACE HeirarchicalBasisGradient_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE HeirarchicalBasisGradient_Line_
+ MODULE PROCEDURE HeirarchicalGradientBasis_Line1_
+END INTERFACE HeirarchicalBasisGradient_Line_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE HeirarchicalBasisGradient_Line
+ MODULE PROCEDURE HeirarchicalGradientBasis_Line2
+END INTERFACE HeirarchicalBasisGradient_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE HeirarchicalBasisGradient_Line_
+ MODULE PROCEDURE HeirarchicalGradientBasis_Line2_
+END INTERFACE HeirarchicalBasisGradient_Line_
+
+!----------------------------------------------------------------------------
+! BasisGradientEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate the gradient of basis functions of order upto n
+
+INTERFACE
+ 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
+ !! point of evaluation
+ 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
+ REAL(DFP) :: ans(order + 1)
+ !! Value of n+1 polynomials at point x
+ END FUNCTION BasisGradientEvalAll_Line1
+END INTERFACE
+
+INTERFACE BasisGradientEvalAll_Line
+ MODULE PROCEDURE BasisGradientEvalAll_Line1
+END INTERFACE BasisGradientEvalAll_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
+
+INTERFACE BasisGradientEvalAll_Line_
+ MODULE PROCEDURE BasisGradientEvalAll_Line1_
+END INTERFACE BasisGradientEvalAll_Line_
+
+!----------------------------------------------------------------------------
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! summary: Evaluate gradient of basis functions of order upto n
+
+INTERFACE
+ 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
+ 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
+ REAL(DFP) :: 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
+ END FUNCTION BasisGradientEvalAll_Line2
+END INTERFACE
+
+INTERFACE BasisGradientEvalAll_Line
+ MODULE PROCEDURE 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
+!----------------------------------------------------------------------------
+
+!> 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)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! Order of interpolation
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature point type
+ !! Equidistance, ! GaussLegendre, ! GaussLegendreLobatto,
+ !! GaussChebyshev, ! GaussChebyshevLobatto, ! GaussJacobi,
+ !! GaussJacobiLobatto
+ 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
+ REAL(DFP), ALLOCATABLE :: 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
+ END FUNCTION QuadraturePoint_Line1
+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_Line1 function
+
+INTERFACE QuadraturePoint_Line
+ 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
+ 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_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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-19
+! summary: Returns quadrature points
+
+INTERFACE QuadraturePoint_Line
+ 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
+ !! Quadrature point type
+ !! Equidistance,
+ !! GaussLegendre,
+ !! GaussLegendreLobatto,
+ !! GaussChebyshev,
+ !! GaussChebyshevLobatto,
+ !! GaussJacobi,
+ !! GaussJacobiLobatto
+ 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
+ REAL(DFP), ALLOCATABLE :: 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
+ END FUNCTION QuadraturePoint_Line3
+END INTERFACE QuadraturePoint_Line
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-07-07
+! summary: Quadrature point on line
+
+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
+ INTEGER(I4B), INTENT(IN) :: quadType
+ !! Quadrature point type
+ !! Equidistance, ! GaussLegendre, ! GaussLegendreLobatto, ! GaussChebyshev,
+ !! GaussChebyshevLobatto, ! GaussJacobi, ! GaussJacobiLobatto
+ 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
+ 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/Geometry/src/Line_Method.F90 b/src/modules/Line/src/Line_Method.F90
similarity index 77%
rename from src/modules/Geometry/src/Line_Method.F90
rename to src/modules/Line/src/Line_Method.F90
index 2c1757412..3eeb8ed22 100644
--- a/src/modules/Geometry/src/Line_Method.F90
+++ b/src/modules/Line/src/Line_Method.F90
@@ -18,6 +18,18 @@
MODULE Line_Method
USE GlobalData
IMPLICIT NONE
+PRIVATE
+
+PUBLIC :: line_exp_is_degenerate_nd, &
+ line_exp2imp_2d, &
+ line_imp_is_degenerate_2d, &
+ lines_imp_int_2d, &
+ line_exp_perp_2d, &
+ lines_exp_int_2d, &
+ segment_point_dist_2d, &
+ segment_point_dist_3d, &
+ line_exp_point_dist_signed_2d, &
+ segment_point_near_2d
!----------------------------------------------------------------------------
!
@@ -46,14 +58,14 @@ MODULE Line_Method
! line is degenerate.
!
-interface
- module pure function line_exp_is_degenerate_nd(dim_num, p1, p2) result(ans)
+INTERFACE
+ MODULE PURE FUNCTION line_exp_is_degenerate_nd(dim_num, p1, p2) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: dim_num
- real(dfp), INTENT(IN) :: p1(dim_num)
- real(dfp), INTENT(IN) :: p2(dim_num)
- logical(lgt) :: ans
- end function
-end interface
+ REAL(dfp), INTENT(IN) :: p1(dim_num)
+ REAL(dfp), INTENT(IN) :: p2(dim_num)
+ LOGICAL(lgt) :: ans
+ END FUNCTION
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -80,13 +92,13 @@ module pure function line_exp_is_degenerate_nd(dim_num, p1, p2) result(ans)
! Output, real ( kind = 8 ) A, B, C, the implicit form of the line.
!
-interface
- module pure subroutine line_exp2imp_2d(p1, p2, a, b, c)
- real(kind=8), intent(out) :: a, b, c
- real(kind=8), intent(in) :: p1(:)
- real(kind=8), intent(in) :: p2(:)
- end subroutine
-end interface
+INTERFACE
+ MODULE PURE SUBROUTINE line_exp2imp_2d(p1, p2, a, b, c)
+ REAL(kind=8), INTENT(out) :: a, b, c
+ REAL(kind=8), INTENT(in) :: p1(:)
+ REAL(kind=8), INTENT(in) :: p2(:)
+ END SUBROUTINE
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -110,12 +122,12 @@ module pure subroutine line_exp2imp_2d(p1, p2, a, b, c)
! line is degenerate.
!
-interface
- module pure function line_imp_is_degenerate_2d(a, b, c) result(ans)
- real(dfp), intent(in) :: a, b, c
- logical(lgt) :: ans
- end function
-end interface
+INTERFACE
+ MODULE PURE FUNCTION line_imp_is_degenerate_2d(a, b, c) RESULT(ans)
+ REAL(dfp), INTENT(in) :: a, b, c
+ LOGICAL(lgt) :: ans
+ END FUNCTION
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -151,14 +163,14 @@ module pure function line_imp_is_degenerate_2d(a, b, c) result(ans)
! the intersection point. Otherwise, P = 0.
!
-interface
- module pure subroutine lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p)
- implicit none
- real(dfp), intent(in) :: a1, b1, c1, a2, b2, c2
- real(dfp), intent(out) :: p(2)
- integer(i4b), intent(out) :: ival
- end subroutine
-end interface
+INTERFACE
+ MODULE PURE SUBROUTINE lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p)
+ IMPLICIT NONE
+ REAL(dfp), INTENT(in) :: a1, b1, c1, a2, b2, c2
+ REAL(dfp), INTENT(out) :: p(2)
+ INTEGER(i4b), INTENT(out) :: ival
+ END SUBROUTINE
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -197,15 +209,15 @@ module pure subroutine lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p)
! Output, logical ( kind = 4 ) FLAG, is TRUE if the value could
! not be computed.
-interface
- module pure subroutine line_exp_perp_2d(p1, p2, p3, p4, flag)
- real(dfp), intent(in) :: p1(2)
- real(dfp), intent(in) :: p2(2)
- real(dfp), intent(in) :: p3(2)
- real(dfp), intent(out) :: p4(2)
- logical(lgt), intent(out) :: flag
- end subroutine
-end interface
+INTERFACE
+ MODULE PURE SUBROUTINE line_exp_perp_2d(p1, p2, p3, p4, flag)
+ REAL(dfp), INTENT(in) :: p1(2)
+ REAL(dfp), INTENT(in) :: p2(2)
+ REAL(dfp), INTENT(in) :: p3(2)
+ REAL(dfp), INTENT(out) :: p4(2)
+ LOGICAL(lgt), INTENT(out) :: flag
+ END SUBROUTINE
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -237,16 +249,16 @@ module pure subroutine line_exp_perp_2d(p1, p2, p3, p4, flag)
! Output, real ( kind = 8 ) P(2), if IVAl = 1, P is
! the intersection point. Otherwise, P = 0.
-interface
- module pure subroutine lines_exp_int_2d(p1, p2, q1, q2, ival, p)
- real(kind=8), intent(in) :: p1(2)
- real(kind=8), intent(in) :: p2(2)
- real(kind=8), intent(in) :: q1(2)
- real(kind=8), intent(in) :: q2(2)
- real(kind=8), intent(out) :: p(2)
- integer(i4b), intent(out) :: ival
- end subroutine
-end interface
+INTERFACE
+ MODULE PURE SUBROUTINE lines_exp_int_2d(p1, p2, q1, q2, ival, p)
+ REAL(kind=8), INTENT(in) :: p1(2)
+ REAL(kind=8), INTENT(in) :: p2(2)
+ REAL(kind=8), INTENT(in) :: q1(2)
+ REAL(kind=8), INTENT(in) :: q2(2)
+ REAL(kind=8), INTENT(out) :: p(2)
+ INTEGER(i4b), INTENT(out) :: ival
+ END SUBROUTINE
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -278,14 +290,14 @@ module pure subroutine lines_exp_int_2d(p1, p2, q1, q2, ival, p)
! Output, real ( kind = 8 ) DIST, the distance from the point to the
! line segment.
-interface
- module pure function segment_point_dist_2d(p1, p2, p) result(dist)
- real(dfp), intent(in) :: p1(2)
- real(dfp), intent(in) :: p2(2)
- real(dfp), intent(in) :: p(2)
- real(dfp) :: dist
- end function
-end interface
+INTERFACE
+ MODULE PURE FUNCTION segment_point_dist_2d(p1, p2, p) RESULT(dist)
+ REAL(dfp), INTENT(in) :: p1(2)
+ REAL(dfp), INTENT(in) :: p2(2)
+ REAL(dfp), INTENT(in) :: p(2)
+ REAL(dfp) :: dist
+ END FUNCTION
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -319,14 +331,14 @@ module pure function segment_point_dist_2d(p1, p2, p) result(dist)
! line segment.
!
-interface
- module pure function segment_point_dist_3d(p1, p2, p) result(dist)
- real(dfp), intent(in) :: p1(3)
- real(dfp), intent(in) :: p2(3)
- real(dfp), intent(in) :: p(3)
- real(dfp) :: dist
- end function
-end interface
+INTERFACE
+ MODULE PURE FUNCTION segment_point_dist_3d(p1, p2, p) RESULT(dist)
+ REAL(dfp), INTENT(in) :: p1(3)
+ REAL(dfp), INTENT(in) :: p2(3)
+ REAL(dfp), INTENT(in) :: p(3)
+ REAL(dfp) :: dist
+ END FUNCTION
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -370,15 +382,15 @@ module pure function segment_point_dist_3d(p1, p2, p) result(dist)
! Output, real ( kind = 8 ) DIST_SIGNED, the signed distance from the
! point to the line.
-interface
- module pure function line_exp_point_dist_signed_2d(p1, p2, p) &
- & result(dist_signed)
- real(dfp), intent(in) :: p(2)
- real(dfp), intent(in) :: p1(2)
- real(dfp), intent(in) :: p2(2)
- real(dfp) :: dist_signed
- end function
-end interface
+INTERFACE
+ MODULE PURE FUNCTION line_exp_point_dist_signed_2d(p1, p2, p) &
+ & RESULT(dist_signed)
+ REAL(dfp), INTENT(in) :: p(2)
+ REAL(dfp), INTENT(in) :: p1(2)
+ REAL(dfp), INTENT(in) :: p2(2)
+ REAL(dfp) :: dist_signed
+ END FUNCTION
+END INTERFACE
!----------------------------------------------------------------------------
!
@@ -417,15 +429,15 @@ module pure function line_exp_point_dist_signed_2d(p1, p2, p) &
! to the points P1 and P2.
!
-interface
- module pure subroutine segment_point_near_2d(p1, p2, p, pn, dist, t)
- real(dfp), intent(in) :: p1(2)
- real(dfp), intent(in) :: p2(2)
- real(dfp), intent(in) :: p(2)
- real(dfp), intent(out) :: pn(2)
- real(dfp), intent(out) :: dist
- real(dfp), intent(out) :: t
- end subroutine
-end interface
+INTERFACE
+ MODULE PURE SUBROUTINE segment_point_near_2d(p1, p2, p, pn, dist, t)
+ REAL(dfp), INTENT(in) :: p1(2)
+ REAL(dfp), INTENT(in) :: p2(2)
+ REAL(dfp), INTENT(in) :: p(2)
+ REAL(dfp), INTENT(out) :: pn(2)
+ REAL(dfp), INTENT(out) :: dist
+ REAL(dfp), INTENT(out) :: t
+ END SUBROUTINE
+END INTERFACE
END MODULE Line_Method
diff --git a/src/modules/Geometry/src/ReferenceLine_Method.F90 b/src/modules/Line/src/ReferenceLine_Method.F90
similarity index 90%
rename from src/modules/Geometry/src/ReferenceLine_Method.F90
rename to src/modules/Line/src/ReferenceLine_Method.F90
index 4a9e9b0e9..8c39b8877 100644
--- a/src/modules/Geometry/src/ReferenceLine_Method.F90
+++ b/src/modules/Line/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
@@ -495,9 +500,9 @@ END SUBROUTINE GetEdgeConnectivity_Line
! date: 2024-04-19
! summary: Returns the element type of each face
-INTERFACE
- MODULE PURE SUBROUTINE GetFaceElemType_Line(elemType, faceElemType, opt, &
- tFaceNodes)
+INTERFACE GetFaceElemType_Line
+ MODULE PURE SUBROUTINE GetFaceElemType_Line1(elemType, faceElemType, opt, &
+ tFaceNodes)
INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
!! name of element
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
@@ -508,8 +513,34 @@ MODULE PURE SUBROUTINE GetFaceElemType_Line(elemType, faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- END SUBROUTINE GetFaceElemType_Line
-END INTERFACE
+ END SUBROUTINE GetFaceElemType_Line1
+END INTERFACE GetFaceElemType_Line
+
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-04-19
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Line
+ MODULE PURE SUBROUTINE GetFaceElemType_Line2(elemType, localFaceNumber, &
+ faceElemType, opt, tFaceNodes)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! name of element
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(INOUT) :: faceElemType
+ !! Element names of faces
+ INTEGER(I4B), INTENT(INOUT) :: tFaceNodes
+ !! Total number of nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Line2
+END INTERFACE GetFaceElemType_Line
!----------------------------------------------------------------------------
!
diff --git a/src/modules/MassMatrix/src/MassMatrix_Method.F90 b/src/modules/MassMatrix/src/MassMatrix_Method.F90
index c2b6ab317..d11f8467e 100644
--- a/src/modules/MassMatrix/src/MassMatrix_Method.F90
+++ b/src/modules/MassMatrix/src/MassMatrix_Method.F90
@@ -20,12 +20,19 @@
! summary: This module contains method to construct finite element matrices
MODULE MassMatrix_Method
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: ElemShapeData_
+USE BaseType, ONLY: FEVariable_
+USE BaseType, ONLY: FEVariableScalar_
+USE BaseType, ONLY: FEVariableVector_
+USE BaseType, ONLY: FEVariableMatrix_
+USE GlobalData, ONLY: DFP, I4B, LGT
+
IMPLICIT NONE
+
PRIVATE
PUBLIC :: MassMatrix
+PUBLIC :: MassMatrix_
PUBLIC :: ViscousBoundaryMassMatrix
!----------------------------------------------------------------------------
@@ -34,17 +41,9 @@ MODULE MassMatrix_Method
!> author: Vikas Sharma, Ph. D.
! date: 6 March 2021
-! summary: This subroutine makes mass matrix in space domain
-!
-!# Introduction
-!
-! This subroutine makes space matrix in space domain, Here Rho $\rho$ is a
-! finite element variable
-!
-! $$\int_{\Omega } N^{I} N^{J}d\Omega$$
-!
+! summary: This subroutine makes mass matrix in space domain (see below)
-INTERFACE MassMatrix
+INTERFACE
MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
!! Shapedata for test function
@@ -54,19 +53,57 @@ MODULE PURE FUNCTION MassMatrix_1(test, trial, opt) RESULT(ans)
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION MassMatrix_1
+END INTERFACE
+
+INTERFACE MassMatrix
+ MODULE PROCEDURE MassMatrix_1
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-11-27
+! summary: This subroutine makes mass matrix in space domain
+!
+!# Introduction
+!
+! This subroutine makes space matrix in space domain, Here mass density
+! is constant and one.
+!
+! $$\int_{\Omega } N^{I} N^{J}d\Omega$$
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix1_(test, trial, ans, nrow, ncol, opt)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ !! Shape function data for test function
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ !! trial function data
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! mass matrix
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! size of mass matrix
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! option for ncopy
+ END SUBROUTINE MassMatrix1_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix1_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 6 March 2021
-! summary: This subroutine makes mass matrix in space domain
+! summary: This subroutine makes mass matrix in space domain (see below)
-INTERFACE MassMatrix
+INTERFACE
MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) &
- & RESULT(ans)
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
!! Shapedata for test function
CLASS(ElemshapeData_), INTENT(IN) :: trial
@@ -78,32 +115,109 @@ MODULE PURE FUNCTION MassMatrix_2(test, trial, rho, rhorank, opt) &
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION MassMatrix_2
+END INTERFACE
+
+INTERFACE MassMatrix
+ MODULE PROCEDURE MassMatrix_2
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-11-27
+! summary: This subroutine makes mass matrix in space domain (see below)
+!
+!# Introduction
+!
+! This subroutine makes space matrix in space domain, Here mass density
+! is a FEVariable of scalar type.
+!
+! ans(I,J)=\int N^{I}\rho N^{J}d\Omega
+
+INTERFACE
+ 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
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix2_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 6 March 2021
-! summary: This subroutine makes mass matrix in space domain
+! summary: This subroutine makes mass matrix in space domain (see below)
-INTERFACE MassMatrix
+INTERFACE
MODULE PURE FUNCTION MassMatrix_3(test, trial, rho, rhorank, opt) &
- & RESULT(ans)
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
!! Shapedata for test function
CLASS(ElemshapeData_), INTENT(IN) :: trial
!! Shapedata for trial function
CLASS(FEVariable_), INTENT(IN) :: rho
+ !! rho
TYPE(FEVariableVector_), INTENT(IN) :: rhorank
!! Vector
INTEGER(I4B), INTENT(IN) :: opt
!! ncopy
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION MassMatrix_3
+END INTERFACE
+
+INTERFACE MassMatrix
+ MODULE PROCEDURE MassMatrix_3
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-11-27
+! summary: This subroutine makes mass matrix in space domain
+!
+!# Introduction
+!
+! This subroutine makes space matrix in space domain, Here mass density
+! is a FEVariable of vector type.
+! Based on opt value following tasks can be perfoemd:
+!
+! opt=1: M_{i1}(I,J)=\int N^{I}v_{i}N^{J}d\Omega
+! opt=2: M_{1i}(I,J)=\int N^{I}v_{i}N^{J}d\Omega
+! opt=3: M_{ii}(I,J)=\int N^{I}v_{i}N^{J}d\Omega
+! opt=4: M_{ij}(I,J)=\int N^{I}v_{i}v_{j}N^{J}d\Omega
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix3_(test, trial, rho, rhorank, opt, &
+ nrow, ncol, ans)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: rho
+ TYPE(FEVariableVector_), INTENT(IN) :: rhorank
+ INTEGER(I4B), INTENT(IN) :: opt
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ END SUBROUTINE MassMatrix3_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix3_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
@@ -112,20 +226,57 @@ END FUNCTION MassMatrix_3
! date: 6 March 2021
! summary: This subroutine makes mass matrix in space domain
-INTERFACE MassMatrix
+INTERFACE
MODULE PURE FUNCTION MassMatrix_4(test, trial, rho, rhorank) &
- & RESULT(ans)
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
!! Shapedata for test function
CLASS(ElemshapeData_), INTENT(IN) :: trial
!! Shapedata for trial function
CLASS(FEVariable_), INTENT(IN) :: rho
+ !! coefficient
TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank
- !! Matrix
+ !! coefficient is a matrix
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION MassMatrix_4
+END INTERFACE
+
+INTERFACE MassMatrix
+ MODULE PROCEDURE MassMatrix_4
END INTERFACE MassMatrix
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-02
+! summary: mass matrix in space
+! notice: not implemented yet
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix4_( &
+ test, trial, rho, rhorank, m4, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ CLASS(FEVariable_), INTENT(IN) :: rho
+ !! FEVariable
+ TYPE(FEVariableMatrix_), INTENT(IN) :: rhorank
+ !! Matrix FEVariable
+ REAL(DFP), INTENT(INOUT) :: m4(:, :, :, :)
+ !! These matrix is needed internally,
+ !! size of m4: nns, nns, size(rho,1), size(rho,2)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! result
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! Data written in ans
+ END SUBROUTINE MassMatrix4_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix4_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
! MassMatrix@MassMatrixMethods
!----------------------------------------------------------------------------
@@ -134,9 +285,10 @@ END FUNCTION MassMatrix_4
! date: 2024-01-15
! summary: This subroutine makes mass matrix used for viscous boundary
-INTERFACE ViscousBoundaryMassMatrix
- MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) &
- & RESULT(ans)
+INTERFACE
+ MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho, &
+ lambdaRank, muRank, rhoRank) &
+ RESULT(ans)
CLASS(ElemshapeData_), INTENT(IN) :: test
!! Shapedata for test function
CLASS(ElemshapeData_), INTENT(IN) :: trial
@@ -147,10 +299,200 @@ MODULE PURE FUNCTION MassMatrix_5(test, trial, lambda, mu, rho) &
!! Lame parameter
CLASS(FEVariable_), INTENT(IN) :: rho
!! Mass Density
+ TYPE(FEVariableScalar_), INTENT(IN) :: lambdaRank, muRank, rhoRank
REAL(DFP), ALLOCATABLE :: ans(:, :)
END FUNCTION MassMatrix_5
+END INTERFACE
+
+INTERFACE MassMatrix
+ MODULE PROCEDURE MassMatrix_5
+END INTERFACE MassMatrix
+
+INTERFACE ViscousBoundaryMassMatrix
+ MODULE PROCEDURE MassMatrix_5
END INTERFACE ViscousBoundaryMassMatrix
+!----------------------------------------------------------------------------
+! MassMatrix@MassMatrixMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-01-15
+! summary: This subroutine makes mass matrix used for viscous boundary
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix5_( &
+ test, trial, lambda, mu, rho, lambdaRank, muRank, rhoRank, ans, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: test
+ !! Shapedata for test function
+ CLASS(ElemshapeData_), INTENT(IN) :: trial
+ !! Shapedata for trial function
+ CLASS(FEVariable_), INTENT(IN) :: lambda
+ !! Lame parameter
+ CLASS(FEVariable_), INTENT(IN) :: mu
+ !! Lame parameter
+ CLASS(FEVariable_), INTENT(IN) :: rho
+ !! Mass Density
+ TYPE(FEVariableScalar_), INTENT(IN) :: lambdaRank, muRank, rhoRank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE MassMatrix5_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix5_
+END INTERFACE MassMatrix_
+
+!----------------------------------------------------------------------------
+! MassMatrix@MassMatrixMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-01-15
+! summary: This subroutine makes mass matrix mass routine
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix6_( &
+ N, M, js, ws, thickness, nips, nns1, nns2, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! test function data
+ REAL(DFP), INTENT(IN) :: M(:, :)
+ !! trial function data
+ REAL(DFP), INTENT(IN) :: js(:)
+ !! Jacobian determinant at integration points
+ REAL(DFP), INTENT(IN) :: ws(:)
+ !! Weights at integration points
+ REAL(DFP), INTENT(IN) :: thickness(:)
+ !! thickness at integration points
+ INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2
+ !! number of integration points
+ !! number of shape functions for test function
+ !! number of shape functions for trial function
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE MassMatrix6_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix6_
+END INTERFACE MassMatrix_
+
+!----------------------------------------------------------------------------
+! MassMatrix@MassMatrixMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-01-15
+! summary: This subroutine makes mass matrix mass routine
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix7_( &
+ N, M, js, ws, thickness, nips, nns1, nns2, skipVertices, tVertices, &
+ ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ !! test function data
+ REAL(DFP), INTENT(IN) :: M(:, :)
+ !! trial function data
+ REAL(DFP), INTENT(IN) :: js(:)
+ !! Jacobian determinant at integration points
+ REAL(DFP), INTENT(IN) :: ws(:)
+ !! Weights at integration points
+ REAL(DFP), INTENT(IN) :: thickness(:)
+ !! thickness at integration points
+ INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2
+ !! number of integration points
+ !! number of shape functions for test function
+ !! number of shape functions for trial function
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ !! If true then we skip 1:tVertices rows and columns
+ INTEGER(I4B), INTENT(IN) :: tVertices
+ !! total number of vertex shape functions to be skipped
+ !! Used when skipVertices is true
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE MassMatrix7_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix7_
+END INTERFACE MassMatrix_
+
+!----------------------------------------------------------------------------
+! MassMatrix@MassMatrixMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-01-15
+! summary: This subroutine makes space time mass matrix in DOF format
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix8_( &
+ spaceN, spaceM, timeN, timeM, js, ws, jt, wt, spaceThickness, &
+ timeThickness, nips, nns1, nns2, nipt, nnt1, nnt2, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: spaceN(:, :), spaceM(:, :)
+ !! test and trial function data in space
+ REAL(DFP), INTENT(IN) :: timeN(:, :), timeM(:, :)
+ !! test and trial function data in time
+ REAL(DFP), INTENT(IN) :: js(:), jt(:)
+ !! Jacobian determinant at integration points
+ REAL(DFP), INTENT(IN) :: ws(:), wt(:)
+ !! Weights at integration points
+ REAL(DFP), INTENT(IN) :: spaceThickness(:), timeThickness(:)
+ !! thickness at integration points
+ INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2, nipt, nnt1, nnt2
+ !! number of integration points
+ !! number of shape functions for test function
+ !! number of shape functions for trial function
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE MassMatrix8_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix8_
+END INTERFACE MassMatrix_
+
+!----------------------------------------------------------------------------
+! MassMatrix@MassMatrixMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-01-15
+! summary: This subroutine makes space time mass matrix in DOF format
+
+INTERFACE
+ MODULE PURE SUBROUTINE MassMatrix9_( &
+ spaceN, spaceM, timeN, timeM, js, ws, jt, wt, spaceThickness, &
+ timeThickness, nips, nns1, nns2, nipt, nnt1, nnt2, &
+ skipVertices, tSpaceVertices, tTimeVertices, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: spaceN(:, :), spaceM(:, :)
+ !! test and trial function data in space
+ REAL(DFP), INTENT(IN) :: timeN(:, :), timeM(:, :)
+ !! test and trial function data in time
+ REAL(DFP), INTENT(IN) :: js(:), jt(:)
+ !! Jacobian determinant at integration points
+ REAL(DFP), INTENT(IN) :: ws(:), wt(:)
+ !! Weights at integration points
+ REAL(DFP), INTENT(IN) :: spaceThickness(:), timeThickness(:)
+ !! thickness at integration points
+ INTEGER(I4B), INTENT(IN) :: nips, nns1, nns2, nipt, nnt1, nnt2
+ !! number of integration points
+ !! number of shape functions for test function
+ !! number of shape functions for trial function
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ !! If true then we skip 1:tSpaceVertices rows and columns
+ INTEGER(I4B), INTENT(IN) :: tSpaceVertices, tTimeVertices
+ !! total number of vertex shape functions to be skipped
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE MassMatrix9_
+END INTERFACE
+
+INTERFACE MassMatrix_
+ MODULE PROCEDURE MassMatrix9_
+END INTERFACE MassMatrix_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
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..9360c656b 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
@@ -77,19 +77,10 @@ MODULE PENF_STRINGIFY
INTERFACE STR
MODULE PROCEDURE &
- & strf_R8P, str_R8P, &
- & strf_R4P, str_R4P, &
- & strf_I8P, str_I8P, &
- & strf_I4P, str_I4P, &
- & strf_I2P, str_I2P, &
- & strf_I1P, str_I1P, &
- & str_bol, &
- & str_a_R8P, &
- & str_a_R4P, &
- & str_a_I8P, &
- & str_a_I4P, &
- & str_a_I2P, &
- & str_a_I1P
+ strf_R8P, str_R8P, strf_R4P, str_R4P, strf_I8P, str_I8P, &
+ strf_I4P, str_I4P, strf_I2P, str_I2P, strf_I1P, str_I1P, &
+ str_bol, str_a_R8P, str_a_R4P, str_a_I8P, str_a_I4P, &
+ str_a_I2P, str_a_I1P
#ifdef _R16P
MODULE PROCEDURE strf_R16P, str_R16P, str_a_R16P
#endif
diff --git a/src/modules/Point/CMakeLists.txt b/src/modules/Point/CMakeLists.txt
new file mode 100644
index 000000000..dbba7b180
--- /dev/null
+++ b/src/modules/Point/CMakeLists.txt
@@ -0,0 +1,19 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(${PROJECT_NAME} PRIVATE ${src_path}/ReferencePoint_Method.F90)
diff --git a/src/modules/Geometry/src/ReferencePoint_Method.F90 b/src/modules/Point/src/ReferencePoint_Method.F90
similarity index 100%
rename from src/modules/Geometry/src/ReferencePoint_Method.F90
rename to src/modules/Point/src/ReferencePoint_Method.F90
diff --git a/src/modules/Polynomial/CMakeLists.txt b/src/modules/Polynomial/CMakeLists.txt
index 86560150e..2404014d2 100644
--- a/src/modules/Polynomial/CMakeLists.txt
+++ b/src/modules/Polynomial/CMakeLists.txt
@@ -1,39 +1,33 @@
-# 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}/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/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..1398c5d4d 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
@@ -166,9 +153,9 @@ END FUNCTION LagrangeVandermonde
! date: 12 Aug 2022
! summary: Returns the Vandermonde matrix
-INTERFACE
- MODULE PURE SUBROUTINE LagrangeVandermonde_(xij, order, elemType, ans, &
- nrow, ncol)
+INTERFACE LagrangeVandermonde_
+ MODULE PURE SUBROUTINE LagrangeVandermonde1_(xij, order, elemType, ans, &
+ nrow, ncol)
REAL(DFP), INTENT(IN) :: xij(:, :)
!! points in $x_{iJ}$ format
INTEGER(I4B), INTENT(IN) :: order
@@ -180,8 +167,32 @@ MODULE PURE SUBROUTINE LagrangeVandermonde_(xij, order, elemType, ans, &
!! nrows := number of points
!! ncols := number of dof
INTEGER(I4B), INTENT(OUT) :: nrow, ncol
- END SUBROUTINE LagrangeVandermonde_
-END INTERFACE
+ END SUBROUTINE LagrangeVandermonde1_
+END INTERFACE LagrangeVandermonde_
+
+!----------------------------------------------------------------------------
+! LagrangeVandermonde
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 12 Aug 2022
+! summary: Returns the Vandermonde matrix
+
+INTERFACE LagrangeVandermonde_
+ MODULE PURE SUBROUTINE LagrangeVandermonde2_(xij, degree, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in $x_{iJ}$ format
+ INTEGER(I4B), INTENT(IN) :: degree(:, :)
+ !! degree of monomials
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! vandermonde matrix
+ !! nrows := number of points
+ !! ncols := number of dof
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xij, 2)
+ !! ncol = SIZE(degree, 1)
+ END SUBROUTINE LagrangeVandermonde2_
+END INTERFACE LagrangeVandermonde_
!----------------------------------------------------------------------------
! EquidistancePoint
@@ -192,11 +203,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 +213,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 +223,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 +259,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 +293,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 +361,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 +407,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 +452,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 +497,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 +558,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 +641,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
deleted file mode 100644
index dda86c81d..000000000
--- a/src/modules/Polynomial/src/LineInterpolationUtility.F90
+++ /dev/null
@@ -1,1179 +0,0 @@
-! This program is a part of EASIFEM library
-! Copyright (C) 2020-2021 Vikas Sharma, Ph.D
-!
-! This program is free software: you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation, either version 3 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License
-! along with this program. If not, see
-!
-
-MODULE LineInterpolationUtility
-USE GlobalData
-USE String_Class, ONLY: String
-IMPLICIT NONE
-PRIVATE
-
-PUBLIC :: LagrangeDegree_Line
-PUBLIC :: LagrangeDOF_Point
-PUBLIC :: LagrangeDOF_Line
-PUBLIC :: LagrangeInDOF_Line
-PUBLIC :: GetTotalDOF_Line
-PUBLIC :: GetTotalInDOF_Line
-PUBLIC :: EquidistanceInPoint_Line
-PUBLIC :: EquidistancePoint_Line
-PUBLIC :: InterpolationPoint_Line
-PUBLIC :: LagrangeCoeff_Line
-PUBLIC :: LagrangeEvalAll_Line
-PUBLIC :: LagrangeGradientEvalAll_Line
-PUBLIC :: BasisEvalAll_Line
-PUBLIC :: BasisGradientEvalAll_Line
-PUBLIC :: QuadraturePoint_Line
-PUBLIC :: ToVEFC_Line
-PUBLIC :: QuadratureNumber_Line
-PUBLIC :: RefElemDomain_Line
-PUBLIC :: HeirarchicalBasis_Line
-PUBLIC :: HeirarchicalGradientBasis_Line
-PUBLIC :: OrthogonalBasis_Line
-PUBLIC :: OrthogonalBasisGradient_Line
-
-!----------------------------------------------------------------------------
-! RefElemDomain_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-03
-! summary: Returns the coordinate of reference element
-
-INTERFACE
- MODULE FUNCTION RefElemDomain_Line(baseContinuity, baseInterpol) &
- & RESULT(ans)
- 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_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! QuadratureNumber_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-20
-! summary: REturns the number of quadrature points necessary for given order
-
-INTERFACE
- MODULE PURE FUNCTION QuadratureNumber_Line(order, quadType) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B), INTENT(IN) :: quadType
- INTEGER(I4B) :: ans
- END FUNCTION QuadratureNumber_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! ToVEFC_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-20
-! summary: Change layour of points on line
-
-INTERFACE
- MODULE PURE SUBROUTINE ToVEFC_Line(pt)
- REAL(DFP), INTENT(INOUT) :: pt(:)
- END SUBROUTINE ToVEFC_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! LagrangeDegree_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 18 Aug 2022
-! summary: Returns the degree of monomials for Lagrange polynomials
-
-INTERFACE
- MODULE PURE FUNCTION LagrangeDegree_Line(order) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B), ALLOCATABLE :: ans(:, :)
- END FUNCTION LagrangeDegree_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! LagrangeDOF_Point
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns the total number of degree of freedom for a
-! lagrange polynomial on a point of Line
-
-INTERFACE
- MODULE PURE FUNCTION LagrangeDOF_Point(order) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B) :: ans
- END FUNCTION LagrangeDOF_Point
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! GetDOF_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns the total number of degree of freedom for a
-! lagrange polynomial on Line
-
-INTERFACE
- MODULE PURE FUNCTION LagrangeDOF_Line(order) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B) :: ans
- END FUNCTION LagrangeDOF_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns the total number of degree of freedom for a
-! lagrange polynomial on an edge of a Line
-!
-!# Introduction
-!
-!- Returns the total number of degree of freedom for a
-! lagrange polynomial on an edge of a Line
-!- These dof are strictly inside the line
-
-INTERFACE
- MODULE PURE FUNCTION LagrangeInDOF_Line(order) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B) :: ans
- END FUNCTION LagrangeInDOF_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! GetTotalDOF_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns the total number of degree of freedom for a
-! lagrange polynomial on Line
-
-INTERFACE
- MODULE PURE FUNCTION GetTotalDOF_Line(order, baseContinuity, &
- baseInterpolation) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- CHARACTER(*), INTENT(IN) :: baseContinuity
- CHARACTER(*), INTENT(IN) :: baseInterpolation
- INTEGER(I4B) :: ans
- END FUNCTION GetTotalDOF_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns the total number of degree of freedom for a
-! lagrange polynomial on an edge of a Line
-!
-!# Introduction
-!
-!- Returns the total number of degree of freedom for a
-! lagrange polynomial on an edge of a Line
-!- These dof are strictly inside the line
-
-INTERFACE
- MODULE PURE FUNCTION GetTotalInDOF_Line(order, baseContinuity, &
- baseInterpolation) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- CHARACTER(*), INTENT(IN) :: baseContinuity
- CHARACTER(*), INTENT(IN) :: baseInterpolation
- INTEGER(I4B) :: ans
- END FUNCTION GetTotalInDOF_Line
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! EquidistanceInPoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns equidistance internal points on edge
-!
-!# Introduction
-!
-!- This function returns the equidistance points on edge in 1D
-!- All points are inside the interval
-!- Points are in increasing order
-
-INTERFACE EquidistanceInPoint_Line
- MODULE PURE FUNCTION EquidistanceInPoint_Line1(order, xij) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order
- REAL(DFP), INTENT(IN) :: xij(2)
- !! coordinates of point 1 and point 2
- REAL(DFP), ALLOCATABLE :: ans(:)
- END FUNCTION EquidistanceInPoint_Line1
-END INTERFACE EquidistanceInPoint_Line
-
-!----------------------------------------------------------------------------
-! EquidistanceInPoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns equidistance points on edge
-!
-!# Introduction
-!
-!- This function returns the equidistance points on edge in 1D, 2D, 3D
-!- The end points are specified by `xij(1:nsd, 1)` and `xij(1:nsd, 2)`
-!
-!- All points are inside the interval
-!- The number of space components in `ans` is nsd if xij present
-!- Otherwise, the number of space components in `ans` is 1.
-
-INTERFACE EquidistanceInPoint_Line
- MODULE PURE FUNCTION EquidistanceInPoint_Line2(order, xij) RESULT(ans)
- 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), 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.
- END FUNCTION EquidistanceInPoint_Line2
-END INTERFACE EquidistanceInPoint_Line
-
-!----------------------------------------------------------------------------
-! EquidistancePoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns equidistance points on edge
-!
-!# Introduction
-!
-!- This function returns the equidistance points on edge
-!- Points are in "VEFC" format, which means `xij(1,1:2)` are end points
-
-INTERFACE EquidistancePoint_Line
- MODULE PURE FUNCTION EquidistancePoint_Line1(order, xij) &
- & RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order
- REAL(DFP), INTENT(IN) :: xij(2)
- !! coorindates of point 1 and point 2
- REAL(DFP), ALLOCATABLE :: ans(:)
- !! equidistance points
- END FUNCTION EquidistancePoint_Line1
-END INTERFACE EquidistancePoint_Line
-
-!----------------------------------------------------------------------------
-! EquidistancePoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns equidistance points on line
-!
-!# Introduction
-!
-!- This function returns the equidistance points on line
-!- All points are inside the interval
-
-INTERFACE EquidistancePoint_Line
- MODULE PURE FUNCTION EquidistancePoint_Line2(order, xij) &
- & RESULT(ans)
- 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), ALLOCATABLE :: 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.
- END FUNCTION EquidistancePoint_Line2
-END INTERFACE EquidistancePoint_Line
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Aug 2022
-! summary: Returns the interpolation point
-!
-!# Introduction
-!
-!- This routine returns the interplation points on line
-!- `xij` contains nodal coordinates of line in xij format.
-!- SIZE(xij,1) = nsd, and SIZE(xij,2)=2
-!- If xij is absent then [-1,1] is used
-!- `ipType` is interpolation point type, it can take following values
-!- `Equidistance`, uniformly/evenly distributed points
-!- `GaussLegendre`, Zeros of Legendre polynomials, all nodes are strictly
-! inside the domain.
-!- `GaussLegendreLobatto` or `GaussLobatto` are zeros of Lobatto polynomials
-! they always contains boundary points
-!- `GaussChebyshev` Zeros of Chebyshev polynomials of first kind, all
-! nodes are internal
-!- `GaussChebyshevLobatto` they contains boundary points
-!- `GaussJacobi` and `GaussJacobiLobatto`
-!
-!- `layout` specifies the arrangement of points. Following options are
-! possible:
-!
-!- `layout=VEFC` vertex, edge, face, cell, in this case first two points are
-! boundary points, remaining (from 3 to n) are internal points in
-! increasing order.
-!
-!- `layout=INCREASING` points are arranged in increasing order
-
-INTERFACE InterpolationPoint_Line
- MODULE FUNCTION InterpolationPoint_Line1(order, ipType, &
- & layout, xij, alpha, beta, lambda) RESULT(ans)
- !!
- INTEGER(I4B), INTENT(IN) :: order
- !! Order of interpolation
- INTEGER(I4B), INTENT(IN) :: ipType
- !! Interpolation point type
- !! Equidistance, GaussLegendre, GaussLegendreLobatto, GaussChebyshev,
- !! GaussChebyshevLobatto, GaussJacobi, GaussJacobiLobatto
- 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
- REAL(DFP), ALLOCATABLE :: ans(:, :)
- !! interpolation points in xij format
- !! size(ans,1) = 1
- !! size(ans,2) = order+1
- END FUNCTION InterpolationPoint_Line1
-END INTERFACE InterpolationPoint_Line
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Aug 2022
-! summary: Returns the interpolation point
-
-INTERFACE InterpolationPoint_Line
- MODULE FUNCTION InterpolationPoint_Line2(order, ipType, xij, &
- & layout, alpha, beta, lambda) RESULT(ans)
- !!
- INTEGER(I4B), INTENT(IN) :: order
- !! order of interpolation
- INTEGER(I4B), INTENT(IN) :: ipType
- !! Interpolation point type
- !! Equidistance
- !! GaussLegendre
- !! GaussLegendreLobatto
- !! GaussChebyshev,
- !! GaussChebyshevLobatto
- !! GaussJacobi
- !! GaussJacobiLobatto
- REAL(DFP), 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
- REAL(DFP), ALLOCATABLE :: ans(:)
- !! one dimensional interpolation point
- END FUNCTION InterpolationPoint_Line2
-END INTERFACE InterpolationPoint_Line
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-INTERFACE LagrangeCoeff_Line
- MODULE FUNCTION LagrangeCoeff_Line1(order, i, xij) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomial, it should be SIZE(xij,2)-1
- INTEGER(I4B), INTENT(IN) :: i
- !! ith coefficients for lagrange polynomial
- REAL(DFP), INTENT(IN) :: xij(:, :)
- !! points in xij format, size(xij,2) = order+1
- REAL(DFP) :: ans(order + 1)
- !! coefficients
- END FUNCTION LagrangeCoeff_Line1
-END INTERFACE LagrangeCoeff_Line
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-INTERFACE LagrangeCoeff_Line
- MODULE FUNCTION LagrangeCoeff_Line2(order, i, v, isVandermonde) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomial, it should be SIZE(v,2)-1
- INTEGER(I4B), INTENT(IN) :: i
- !! coefficient for ith lagrange polynomial
- REAL(DFP), INTENT(IN) :: v(:, :)
- !! vandermonde matrix size should be (order+1,order+1)
- LOGICAL(LGT), INTENT(IN) :: isVandermonde
- !! This is just to resolve interface issue
- REAL(DFP) :: ans(order + 1)
- !! coefficients
- END FUNCTION LagrangeCoeff_Line2
-END INTERFACE LagrangeCoeff_Line
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-INTERFACE LagrangeCoeff_Line
- MODULE FUNCTION LagrangeCoeff_Line3(order, i, v, ipiv) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomial, it should be SIZE(x,2)-1
- INTEGER(I4B), INTENT(IN) :: i
- !! ith coefficients for lagrange polynomial
- REAL(DFP), INTENT(INOUT) :: v(:, :)
- !! LU decomposition of vandermonde matrix
- INTEGER(I4B), INTENT(IN) :: ipiv(:)
- !! inverse pivoting mapping, compes from LU decomposition
- REAL(DFP) :: ans(order + 1)
- !! coefficients
- END FUNCTION LagrangeCoeff_Line3
-END INTERFACE LagrangeCoeff_Line
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-INTERFACE LagrangeCoeff_Line
- MODULE FUNCTION LagrangeCoeff_Line4(order, xij) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomial, it should be SIZE(xij,2)-1
- REAL(DFP), INTENT(IN) :: xij(:, :)
- !! points in xij format, size(xij,2) = order+1
- REAL(DFP) :: ans(order + 1, order + 1)
- !! coefficients
- !! jth column of ans corresponds to the coeff of lagrange polynomial
- !! at the jth point
- END FUNCTION LagrangeCoeff_Line4
-END INTERFACE LagrangeCoeff_Line
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-INTERFACE LagrangeCoeff_Line
- MODULE FUNCTION LagrangeCoeff_Line5(order, xij, basisType, alpha, &
- & 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
- 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) :: ans(SIZE(xij, 2), SIZE(xij, 2))
- !! coefficients
- !! jth column of ans corresponds to the coeff of lagrange polynomial
- !! at the jth point
- END FUNCTION LagrangeCoeff_Line5
-END INTERFACE LagrangeCoeff_Line
-
-!----------------------------------------------------------------------------
-! LagrangeEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! summary: Evaluate Lagrange polynomials of order n at single points
-
-INTERFACE LagrangeEvalAll_Line
- MODULE FUNCTION LagrangeEvalAll_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
- !! point of evaluation
- REAL(DFP), INTENT(INOUT) :: xij(:, :)
- !! interpolation points
- 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
- REAL(DFP) :: ans(SIZE(xij, 2))
- !! Value of n+1 Lagrange polynomials at point x
- END FUNCTION LagrangeEvalAll_Line1
-END INTERFACE LagrangeEvalAll_Line
-
-!----------------------------------------------------------------------------
-! LagrangeEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! 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)
- 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), 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
- REAL(DFP) :: 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
- END FUNCTION LagrangeEvalAll_Line2
-END INTERFACE LagrangeEvalAll_Line
-
-!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! 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)
- 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), 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
- REAL(DFP) :: ans(SIZE(x, 2), SIZE(xij, 2), 1)
- !! 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
- 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)
- 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
- !! 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) :: ans(order + 1)
- !! Value of n+1 polynomials at point x
- END FUNCTION BasisEvalAll_Line1
-END INTERFACE BasisEvalAll_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_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
- 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
- REAL(DFP) :: 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
- END FUNCTION BasisEvalAll_Line2
-END INTERFACE BasisEvalAll_Line
-
-!----------------------------------------------------------------------------
-! BasisEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! summary: Evaluate basis functions of order upto n
-
-INTERFACE OrthogonalBasis_Line
- 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
- 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) :: ans(SIZE(xij, 2), 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
- END FUNCTION OrthogonalBasis_Line1
-END INTERFACE OrthogonalBasis_Line
-
-!----------------------------------------------------------------------------
-! BasisEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! summary: Evaluate basis functions of order upto n
-
-INTERFACE OrthogonalBasisGradient_Line
- 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(:, :)
- !! 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) :: 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
- END FUNCTION OrthogonalBasisGradient_Line1
-END INTERFACE OrthogonalBasisGradient_Line
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Evaluate all modal basis (heirarchical polynomial) on Line
-
-INTERFACE HeirarchicalBasis_Line
- MODULE FUNCTION HeirarchicalBasis_Line1(order, xij, refLine) RESULT(ans)
- 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) :: ans(SIZE(xij, 2), order + 1)
- !! Hierarchical basis
- END FUNCTION HeirarchicalBasis_Line1
-END INTERFACE HeirarchicalBasis_Line
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! 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)
- 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) :: ans(SIZE(xij, 2), order + 1, 1)
- !! Gradient of Hierarchical basis
- END FUNCTION HeirarchicalGradientBasis_Line1
-END INTERFACE HeirarchicalGradientBasis_Line
-
-!----------------------------------------------------------------------------
-! BasisGradientEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! 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)
- 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
- !! 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) :: ans(order + 1)
- !! Value of n+1 polynomials at point x
- END FUNCTION BasisGradientEvalAll_Line1
-END INTERFACE BasisGradientEvalAll_Line
-
-!----------------------------------------------------------------------------
-! BasisEvalAll_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! 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)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomials
- REAL(DFP), INTENT(IN) :: x(:)
- !! point of evaluation
- 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
- REAL(DFP) :: 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
- END FUNCTION BasisGradientEvalAll_Line2
-END INTERFACE BasisGradientEvalAll_Line
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-19
-! summary: Returns quadrature points
-
-INTERFACE QuadraturePoint_Line
- 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,
- !! GaussJacobiLobatto
- 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
- REAL(DFP), ALLOCATABLE :: 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
- END FUNCTION QuadraturePoint_Line1
-END INTERFACE QuadraturePoint_Line
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Aug 2022
-! summary: Returns the interpolation point
-
-INTERFACE QuadraturePoint_Line
- 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
- 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_Line2
-END INTERFACE QuadraturePoint_Line
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-19
-! summary: Returns quadrature points
-
-INTERFACE QuadraturePoint_Line
- 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
- !! Quadrature point type
- !! Equidistance,
- !! GaussLegendre,
- !! GaussLegendreLobatto,
- !! GaussChebyshev,
- !! GaussChebyshevLobatto,
- !! GaussJacobi,
- !! GaussJacobiLobatto
- 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
- REAL(DFP), ALLOCATABLE :: 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
- END FUNCTION QuadraturePoint_Line3
-END INTERFACE QuadraturePoint_Line
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Line
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Aug 2022
-! summary: Returns the interpolation point
-
-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
-
-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/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/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/Prism/CMakeLists.txt b/src/modules/Prism/CMakeLists.txt
new file mode 100644
index 000000000..8290684d9
--- /dev/null
+++ b/src/modules/Prism/CMakeLists.txt
@@ -0,0 +1,21 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME} PRIVATE ${src_path}/ReferencePrism_Method.F90
+ ${src_path}/PrismInterpolationUtility.F90)
diff --git a/src/modules/Polynomial/src/PrismInterpolationUtility.F90 b/src/modules/Prism/src/PrismInterpolationUtility.F90
similarity index 66%
rename from src/modules/Polynomial/src/PrismInterpolationUtility.F90
rename to src/modules/Prism/src/PrismInterpolationUtility.F90
index 40ced9a38..adebc985b 100644
--- a/src/modules/Polynomial/src/PrismInterpolationUtility.F90
+++ b/src/modules/Prism/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/Geometry/src/ReferencePrism_Method.F90 b/src/modules/Prism/src/ReferencePrism_Method.F90
similarity index 91%
rename from src/modules/Geometry/src/ReferencePrism_Method.F90
rename to src/modules/Prism/src/ReferencePrism_Method.F90
index 486e6237e..9a9eda535 100644
--- a/src/modules/Geometry/src/ReferencePrism_Method.F90
+++ b/src/modules/Prism/src/ReferencePrism_Method.F90
@@ -387,9 +387,12 @@ END FUNCTION RefCoord_Prism
! date: 2024-03-11
! summary: Returns the element type of each face
-INTERFACE
- MODULE PURE SUBROUTINE GetFaceElemType_Prism(faceElemType, opt, &
- & tFaceNodes, elemType)
+INTERFACE GetFaceElemType_Prism
+ MODULE PURE SUBROUTINE GetFaceElemType_Prism1(elemType, faceElemType, &
+ tFaceNodes, opt)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
+ !! elemType for prism
+ !! default is Prism
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
!! Face element type
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:)
@@ -398,10 +401,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Prism(faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
- !! elemType for prism
- !! default is Prism
- END SUBROUTINE GetFaceElemType_Prism
-END INTERFACE
+ END SUBROUTINE GetFaceElemType_Prism1
+END INTERFACE GetFaceElemType_Prism
+
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-03-11
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Prism
+ MODULE PURE SUBROUTINE GetFaceElemType_Prism2( &
+ elemType, localFaceNumber, faceElemType, tFaceNodes, opt)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type for prism
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Face element type
+ INTEGER(I4B), INTENT(OUT) :: tFaceNodes
+ !! total nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Prism2
+END INTERFACE GetFaceElemType_Prism
END MODULE ReferencePrism_Method
diff --git a/src/modules/Projection/CMakeLists.txt b/src/modules/Projection/CMakeLists.txt
new file mode 100644
index 000000000..4a3f0dd7c
--- /dev/null
+++ b/src/modules/Projection/CMakeLists.txt
@@ -0,0 +1,19 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(${PROJECT_NAME} PRIVATE ${src_path}/Projection_Method.F90)
diff --git a/src/modules/Projection/src/Projection_Method.F90 b/src/modules/Projection/src/Projection_Method.F90
new file mode 100644
index 000000000..f9baf2490
--- /dev/null
+++ b/src/modules/Projection/src/Projection_Method.F90
@@ -0,0 +1,201 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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
+!
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-12-01
+! summary: This module contains projection methods for getting DOF values
+! This module uses ElemshapeData, various matrix and forceVector
+! modules
+
+MODULE Projection_Method
+USE GlobalData, ONLY: DFP, I4B, LGT
+USE BaseType, ONLY: ElemShapeData_
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: GetL2ProjectionDOFValueFromQuadrature
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-12-01
+! summary: L2 Projection method to get DOF values
+
+INTERFACE
+ MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1( &
+ elemsd, func, ans, tsize, massMat, ipiv, skipVertices, tVertices)
+ TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd
+ !! shape function defined on the face of element
+ REAL(DFP), INTENT(INOUT) :: func(:)
+ !! user defined functions
+ !! quadrature values of function
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! nodal coordinates of interpolation points
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! data written in xij
+ REAL(DFP), INTENT(INOUT) :: massMat(:, :)
+ !! mass matrix
+ INTEGER(I4B), INTENT(INOUT) :: ipiv(:)
+ !! pivot indices for LU decomposition of mass matrix
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ !! if true then we include only face bubble, that is,
+ !! only include internal face bubble.
+ INTEGER(I4B), INTENT(IN) :: tVertices
+ !! tVertices are needed when onlyFaceBubble is true
+ !! tVertices are total number of vertex degree of
+ !! freedom
+ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature1
+END INTERFACE
+
+INTERFACE GetL2ProjectionDOFValueFromQuadrature
+ MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1
+END INTERFACE GetL2ProjectionDOFValueFromQuadrature
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-12-01
+! summary: L2 Projection method to get DOF values
+
+INTERFACE
+ MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2( &
+ elemsd, timeElemsd, func, ans, tsize, massMat, ipiv, &
+ skipVertices, tSpaceVertices, tTimeVertices)
+ TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd, timeElemsd
+ !! shape function defined on the face of space element
+ !! timeElemsd is shape function data for time element
+ REAL(DFP), INTENT(INOUT) :: func(:, :)
+ !! user defined functions quadrature values of function
+ !! Each column contains value at a given time quadrature points
+ !! Each row contains value at a given space quadrature points
+ !! Size should be atleast elemsd%nips by timeElemsd%nips
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! nodal coordinates of interpolation points
+ !! These are in DOF Format
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! data written in ans
+ REAL(DFP), INTENT(INOUT) :: massMat(:, :)
+ !! mass matrix, the size should be atleast nns * nnt by nns * nnt
+ !! We will make space time mass matrix here
+ INTEGER(I4B), INTENT(INOUT) :: ipiv(:)
+ !! pivot indices for LU decomposition of mass matrix
+ !! the size should be atleast nns * nnt
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ !! if true then we include only face bubble, that is,
+ !! only include internal face bubble.
+ INTEGER(I4B), INTENT(IN) :: tSpaceVertices
+ !! tSpaceVertices are needed when onlyFaceBubble is true
+ !! tSpaceVertices are total number of vertex degree of
+ !! freedom in space
+ INTEGER(I4B), INTENT(IN) :: tTimeVertices
+ !! tTimeVertices are needed when onlyFaceBubble is true
+ !! tTimeVertices are total number of vertex degree of
+ !! freedom in Time
+ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature2
+END INTERFACE
+
+INTERFACE GetL2ProjectionDOFValueFromQuadrature
+ MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2
+END INTERFACE GetL2ProjectionDOFValueFromQuadrature
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-12-01
+! summary: L2 Projection of constant function
+
+INTERFACE
+ MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature3( &
+ elemsd, ans, tsize, massMat, ipiv, skipVertices, tVertices)
+ TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd
+ !! shape function defined on the face of element
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! nodal coordinates of interpolation points
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! data written in xij
+ REAL(DFP), INTENT(INOUT) :: massMat(:, :)
+ !! mass matrix
+ INTEGER(I4B), INTENT(INOUT) :: ipiv(:)
+ !! pivot indices for LU decomposition of mass matrix
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ !! if true then we include only face bubble, that is,
+ !! only include internal face bubble.
+ INTEGER(I4B), INTENT(IN) :: tVertices
+ !! tVertices are needed when onlyFaceBubble is true
+ !! tVertices are total number of vertex degree of
+ !! freedom
+ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature3
+END INTERFACE
+
+INTERFACE GetL2ProjectionDOFValueFromQuadrature
+ MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature3
+END INTERFACE GetL2ProjectionDOFValueFromQuadrature
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-12-01
+! summary: L2 Projection method to get DOF values
+
+INTERFACE
+ MODULE SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature4( &
+ elemsd, timeElemsd, ans, tsize, massMat, ipiv, &
+ skipVertices, tSpaceVertices, tTimeVertices)
+ TYPE(ElemShapeData_), INTENT(INOUT) :: elemsd, timeElemsd
+ !! shape function defined on the face of space element
+ !! timeElemsd is shape function data for time element
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ !! nodal coordinates of interpolation points
+ !! These are in DOF Format
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! data written in ans
+ REAL(DFP), INTENT(INOUT) :: massMat(:, :)
+ !! mass matrix, the size should be atleast nns * nnt by nns * nnt
+ !! We will make space time mass matrix here
+ INTEGER(I4B), INTENT(INOUT) :: ipiv(:)
+ !! pivot indices for LU decomposition of mass matrix
+ !! the size should be atleast nns * nnt
+ LOGICAL(LGT), INTENT(IN) :: skipVertices
+ !! if true then we include only face bubble, that is,
+ !! only include internal face bubble.
+ INTEGER(I4B), INTENT(IN) :: tSpaceVertices
+ !! tSpaceVertices are needed when onlyFaceBubble is true
+ !! tSpaceVertices are total number of vertex degree of
+ !! freedom in space
+ INTEGER(I4B), INTENT(IN) :: tTimeVertices
+ !! tTimeVertices are needed when onlyFaceBubble is true
+ !! tTimeVertices are total number of vertex degree of
+ !! freedom in Time
+ END SUBROUTINE obj_GetL2ProjectionDOFValueFromQuadrature4
+END INTERFACE
+
+INTERFACE GetL2ProjectionDOFValueFromQuadrature
+ MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature4
+END INTERFACE GetL2ProjectionDOFValueFromQuadrature
+
+END MODULE Projection_Method
diff --git a/src/modules/Pyramid/CMakeLists.txt b/src/modules/Pyramid/CMakeLists.txt
new file mode 100644
index 000000000..6d28594e0
--- /dev/null
+++ b/src/modules/Pyramid/CMakeLists.txt
@@ -0,0 +1,22 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferencePyramid_Method.F90
+ PRIVATE ${src_path}/PyramidInterpolationUtility.F90)
diff --git a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90 b/src/modules/Pyramid/src/PyramidInterpolationUtility.F90
similarity index 67%
rename from src/modules/Polynomial/src/PyramidInterpolationUtility.F90
rename to src/modules/Pyramid/src/PyramidInterpolationUtility.F90
index 12147960d..ba78b888e 100644
--- a/src/modules/Polynomial/src/PyramidInterpolationUtility.F90
+++ b/src/modules/Pyramid/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/Geometry/src/ReferencePyramid_Method.F90 b/src/modules/Pyramid/src/ReferencePyramid_Method.F90
similarity index 90%
rename from src/modules/Geometry/src/ReferencePyramid_Method.F90
rename to src/modules/Pyramid/src/ReferencePyramid_Method.F90
index 64e15d10c..f468e75cb 100644
--- a/src/modules/Geometry/src/ReferencePyramid_Method.F90
+++ b/src/modules/Pyramid/src/ReferencePyramid_Method.F90
@@ -335,9 +335,11 @@ END FUNCTION RefCoord_Pyramid
! date: 2024-03-11
! summary: Returns the element type of each face
-INTERFACE
- MODULE PURE SUBROUTINE GetFaceElemType_Pyramid(faceElemType, opt, &
- & tFaceNodes, elemType)
+INTERFACE GetFaceElemType_Pyramid
+ MODULE PURE SUBROUTINE GetFaceElemType_Pyramid1(elemType, faceElemType, &
+ tFaceNodes, opt)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
+ !! Element type
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
!! Face element type
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:)
@@ -346,9 +348,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Pyramid(faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
- !! Element type
- END SUBROUTINE GetFaceElemType_Pyramid
-END INTERFACE
+ END SUBROUTINE GetFaceElemType_Pyramid1
+END INTERFACE GetFaceElemType_Pyramid
+
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-03-11
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Pyramid
+ MODULE PURE SUBROUTINE GetFaceElemType_Pyramid2( &
+ elemType, localFaceNumber, faceElemType, tFaceNodes, opt)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element type for prism
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Face element type
+ INTEGER(I4B), INTENT(OUT) :: tFaceNodes
+ !! total nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Pyramid2
+END INTERFACE GetFaceElemType_Pyramid
END MODULE ReferencePyramid_Method
diff --git a/src/modules/Quadrangle/CMakeLists.txt b/src/modules/Quadrangle/CMakeLists.txt
new file mode 100644
index 000000000..4f74c0af2
--- /dev/null
+++ b/src/modules/Quadrangle/CMakeLists.txt
@@ -0,0 +1,22 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferenceQuadrangle_Method.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility.F90)
diff --git a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90 b/src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90
similarity index 52%
rename from src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90
rename to src/modules/Quadrangle/src/QuadrangleInterpolationUtility.F90
index 20109601e..c344df87a 100644
--- a/src/modules/Polynomial/src/QuadrangleInterpolationUtility.F90
+++ b/src/modules/Quadrangle/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
@@ -15,44 +15,110 @@
!
MODULE QuadrangleInterpolationUtility
-USE GlobalData
+USE GlobalData, ONLY: I4B, DFP, LGT, stderr
USE String_Class, ONLY: String
+USE BaseType, ONLY: TypeInterpolationOpt, &
+ TypeQuadratureOpt, &
+ TypeElemNameOpt, &
+ TypePolynomialOpt
+
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
+PUBLIC :: GetHierarchicalDOF_Quadrangle
+
+!----------------------------------------------------------------------------
+! GetHierarchicalDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-18
+! summary: Get the Hierarchical DOF for Quadrangle
+
+! order, pe1, pe2, pe3
+INTERFACE
+ MODULE PURE FUNCTION GetHierarchicalDOF_Quadrangle( &
+ pb, qb, pe3, pe4, qe1, qe2, opt) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: pb, qb
+ !! cell order
+ INTEGER(I4B), INTENT(IN) :: qe1, qe2, pe3, pe4
+ !! face order
+ CHARACTER(1), INTENT(IN) :: opt
+ !! 'V' - vertex
+ !! 'E' - edge
+ !! 'C' - cell
+ !! 'H' - total hierarchical dof
+ INTEGER(I4B) :: ans
+ END FUNCTION GetHierarchicalDOF_Quadrangle
+END INTERFACE
+
!----------------------------------------------------------------------------
-! GetTotalDOF_Quadrangle
+! GetTotalDOF_Quadrangle@DOFMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -71,7 +137,7 @@ END FUNCTION GetTotalDOF_Quadrangle
END INTERFACE
!----------------------------------------------------------------------------
-! LagrangeInDOF_Quadrangle
+! LagrangeInDOF_Quadrangle@DOFMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -85,106 +151,32 @@ 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
-
-!----------------------------------------------------------------------------
-! RefElemDomain_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-03
-! summary: Returns the coordinate of reference element
-
-INTERFACE
- MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) &
- & RESULT(ans)
- 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_Quadrangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! FacetConnectivity_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-08-10
-! summary: This function returns the edge connectivity of Quadrangle
-
-INTERFACE
- MODULE FUNCTION FacetConnectivity_Quadrangle( &
- & baseInterpol, &
- & baseContinuity) RESULT(ans)
- CHARACTER(*), INTENT(IN) :: baseInterpol
- CHARACTER(*), INTENT(IN) :: baseContinuity
- INTEGER(I4B) :: ans(2, 4)
- !! rows represents the end points of an edges
- !! columns denote the edge (facet)
- END FUNCTION FacetConnectivity_Quadrangle
-END INTERFACE
+ END FUNCTION GetTotalInDOF_Quadrangle1
+END INTERFACE GetTotalInDOF_Quadrangle
!----------------------------------------------------------------------------
-! QuadratureNumber_Quadrangle
+! GetTotalInDOF_Quadrangle@DOFMethods
!----------------------------------------------------------------------------
-INTERFACE
- MODULE PURE FUNCTION QuadratureNumber_Quadrangle( &
- & p, &
- & q, &
- & quadType1, &
- & quadType2) RESULT(ans)
+INTERFACE GetTotalInDOF_Quadrangle
+ MODULE PURE FUNCTION GetTotalInDOF_Quadrangle2(p, q, baseContinuity, &
+ baseInterpolation) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: p, q
- INTEGER(I4B), INTENT(IN) :: quadType1, quadType2
- INTEGER(I4B) :: ans(2)
- END FUNCTION QuadratureNumber_Quadrangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! 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_Quadrangle1(order) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B), ALLOCATABLE :: ans(:, :)
- END FUNCTION 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
- INTEGER(I4B), INTENT(IN) :: q
- INTEGER(I4B), ALLOCATABLE :: ans(:, :)
- END FUNCTION LagrangeDegree_Quadrangle2
-END INTERFACE LagrangeDegree_Quadrangle
+ CHARACTER(*), INTENT(IN) :: baseContinuity
+ CHARACTER(*), INTENT(IN) :: baseInterpolation
+ INTEGER(I4B) :: ans
+ END FUNCTION GetTotalInDOF_Quadrangle2
+END INTERFACE GetTotalInDOF_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeDOF_Quadrangle
+! LagrangeDOF_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -200,7 +192,7 @@ END FUNCTION LagrangeDOF_Quadrangle1
END INTERFACE LagrangeDOF_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeDOF_Quadrangle
+! LagrangeDOF_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -217,7 +209,7 @@ END FUNCTION LagrangeDOF_Quadrangle2
END INTERFACE LagrangeDOF_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeInDOF_Quadrangle
+! LagrangeInDOF_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -239,7 +231,7 @@ END FUNCTION LagrangeInDOF_Quadrangle1
END INTERFACE LagrangeInDOF_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeInDOF_Quadrangle
+! LagrangeInDOF_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -261,361 +253,87 @@ END FUNCTION LagrangeInDOF_Quadrangle2
END INTERFACE LagrangeInDOF_Quadrangle
!----------------------------------------------------------------------------
-! EquidistancePoint_Quadrangle
+! LagrangeDegree_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 12 Aug 2022
-! summary: Returns the nodal coordinates of higher order Quadrangle element
-!
-!# Introduction
-!
-!- This function returns the nodal coordinates of higher order
-! Quadrangle element
-!- The coordinates are distributed uniformly
-!- These coordinates can be used to construct lagrange polynomials
-!- The returned coordinates are in $x_{iJ}$ format.
-!- The node numbering is according to Gmsh convention.
+! date: 18 Aug 2022
+! summary: Returns the degree of monomials for Lagrange polynomials
-INTERFACE EquidistancePoint_Quadrangle
- MODULE RECURSIVE PURE FUNCTION EquidistancePoint_Quadrangle1(order, xij) &
- & RESULT(ans)
+INTERFACE LagrangeDegree_Quadrangle
+ MODULE PURE FUNCTION LagrangeDegree_Quadrangle1(order) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: order
- !! order
- REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
- !! Nodal coordinates of quadrangle
- !! number of rows = 2
- !! number of cols = 4
- REAL(DFP), ALLOCATABLE :: 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
- END FUNCTION EquidistancePoint_Quadrangle1
-END INTERFACE EquidistancePoint_Quadrangle
+ INTEGER(I4B), ALLOCATABLE :: ans(:, :)
+ END FUNCTION LagrangeDegree_Quadrangle1
+END INTERFACE LagrangeDegree_Quadrangle
!----------------------------------------------------------------------------
-! EquidistancePoint_Quadrangle
+! LagrangeDegree_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 12 Aug 2022
-! summary: Returns the nodal coordinates of higher order Quadrangle element
-!
-!# Introduction
-!
-!- This function returns the nodal coordinates of higher order
-! Quadrangle element
-!- The coordinates are distributed uniformly
-!- These coordinates can be used to construct lagrange polynomials
-!- The returned coordinates are in $x_{iJ}$ format.
-!- The node numbering is according to Gmsh convention.
+! date: 18 Aug 2022
+! summary: Returns the degree of monomials for Lagrange polynomials
-INTERFACE EquidistancePoint_Quadrangle
- MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, &
- & xij) RESULT(ans)
- 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), ALLOCATABLE :: 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
- END FUNCTION EquidistancePoint_Quadrangle2
-END INTERFACE EquidistancePoint_Quadrangle
+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_
!----------------------------------------------------------------------------
-! EquidistanceInPoint_Quadrangle
+! LagrangeDegree_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns equidistance points in Quadrangle
-!
-!# Introduction
-!
-!- This function returns the equidistance points in Quadrangle
-!- All points are inside the Quadrangle
+! date: 18 Aug 2022
+! summary: Returns the degree of monomials for Lagrange polynomials
-INTERFACE EquidistanceInPoint_Quadrangle
- MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) &
- & RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order
- REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
- !! Nodal coordinates of quadrangle
- !! number of rows = 2 or 3
- !! number of cols = 4
- REAL(DFP), ALLOCATABLE :: 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
- END FUNCTION EquidistanceInPoint_Quadrangle1
-END INTERFACE EquidistanceInPoint_Quadrangle
+INTERFACE LagrangeDegree_Quadrangle
+ MODULE PURE FUNCTION LagrangeDegree_Quadrangle2(p, q) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: p
+ INTEGER(I4B), INTENT(IN) :: q
+ INTEGER(I4B), ALLOCATABLE :: ans(:, :)
+ END FUNCTION LagrangeDegree_Quadrangle2
+END INTERFACE LagrangeDegree_Quadrangle
!----------------------------------------------------------------------------
-! EquidistanceInPoint_Quadrangle
+! LagrangeDegree_Quadrangle_@LagrangeMethods
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 14 Aug 2022
-! summary: Returns equidistance points in Quadrangle
-!
-!# Introduction
-!
-!- This function returns the equidistance points in Quadrangle
-!- All points are inside the 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_
-INTERFACE EquidistanceInPoint_Quadrangle
- MODULE PURE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) &
- & RESULT(ans)
+!----------------------------------------------------------------------------
+! MonomialBasis_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE MonomialBasis_Quadrangle_( &
+ p, q, xij, ans, nrow, ncol)
INTEGER(I4B), INTENT(IN) :: p
- !! order in x direction
+ !! order of interpolation inside the quadrangle in x1 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), ALLOCATABLE :: 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
- END FUNCTION EquidistanceInPoint_Quadrangle2
-END INTERFACE EquidistanceInPoint_Quadrangle
+ !! 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) -> Number of points of evaluation
+ !! ncol = (p + 1) * (q + 1)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE MonomialBasis_Quadrangle_
+END INTERFACE
!----------------------------------------------------------------------------
-! InterpolationPoint_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 18 Aug 2022
-! summary: Interpolation point
-!
-!# Introduction
-!
-! In this case order is same in both x1 and x2 direction. Therefore,
-! (N+1)**2 grid points are returned.
-!
-! Also in both x1 and x2 same type of grid family will be used.
-!
-!- This routine returns the interplation points on quad
-!- `xij` contains nodal coordinates of quad in xij format.
-!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4
-!- If xij is absent then biunit quad is used
-!- `ipType` is interpolation point type, it can take following values
-!- `Equidistance`, uniformly/evenly distributed points
-!- `GaussLegendreLobatto
-!- `GaussChebyshevLobatto
-!
-!- `layout` specifies the arrangement of points. The nodes are always
-! returned in VEFC format (vertex, edge, face, cell). 1:3 are are
-! vertex points, then edge, and then internal nodes. The internal nodes
-! also follow the same convention. Please read Gmsh manual on this topic.
-
-INTERFACE InterpolationPoint_Quadrangle
- 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
- !! interpolation point type
- !! 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(:, :)
- !! 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), ALLOCATABLE :: ans(:, :)
- !! interpolation points in xij format
- END FUNCTION InterpolationPoint_Quadrangle1
-END INTERFACE InterpolationPoint_Quadrangle
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 18 Aug 2022
-! summary: Interpolation point
-!
-!# Introduction
-!
-! In this case order is same in both x1 and x2 direction. Therefore,
-! (N+1)**2 grid points are returned.
-!
-! Also in both x1 and x2 same type of grid family will be used.
-!
-!- This routine returns the interplation points on quad
-!- `xij` contains nodal coordinates of quad in xij format.
-!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4
-!- If xij is absent then biunit quad is used
-!- `ipType` is interpolation point type, it can take following values
-!- `Equidistance`, uniformly/evenly distributed points
-!- `GaussLegendreLobatto
-!- `GaussChebyshevLobatto
-!
-!- `layout` specifies the arrangement of points. The nodes are always
-! returned in VEFC format (vertex, edge, face, cell). 1:3 are are
-! vertex points, then edge, and then internal nodes. The internal nodes
-! also follow the same convention. Please read Gmsh manual on this topic.
-
-INTERFACE InterpolationPoint_Quadrangle
- 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(:, :)
- !! 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), ALLOCATABLE :: ans(:, :)
- !! interpolation points in xij format
- END FUNCTION InterpolationPoint_Quadrangle2
-END INTERFACE InterpolationPoint_Quadrangle
-
-!----------------------------------------------------------------------------
-! IJ2VEFC
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-17
-! summary: Convert format from IJ to VEFC
-
-INTERFACE
- MODULE SUBROUTINE IJ2VEFC_Quadrangle(xi, eta, temp, p, q)
- REAL(DFP), INTENT(IN) :: xi(:, :)
- REAL(DFP), INTENT(IN) :: eta(:, :)
- REAL(DFP), INTENT(OUT) :: temp(:, :)
- INTEGER(I4B), INTENT(IN) :: p
- INTEGER(I4B), INTENT(IN) :: q
- END SUBROUTINE IJ2VEFC_Quadrangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-17
-! summary: Convert format from IJ to VEFC
-
-INTERFACE
- 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(:, :)
- INTEGER(I4B), INTENT(IN) :: p
- INTEGER(I4B), INTENT(IN) :: q
- INTEGER(I4B), INTENT(IN) :: startNode
- END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise
-END INTERFACE
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-17
-! summary: Convert format from IJ to VEFC
-
-INTERFACE
- 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(:, :)
- INTEGER(I4B), INTENT(IN) :: p
- INTEGER(I4B), INTENT(IN) :: q
- INTEGER(I4B), INTENT(IN) :: startNode
- END SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
+! LagrangeCoeff_Quadrangle@LagrangeMethods
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Quadrangle
@@ -632,12 +350,31 @@ END FUNCTION LagrangeCoeff_Quadrangle1
END INTERFACE LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
+! LagrangeCoeff_Quadrangle_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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@LagrangeMethods
!----------------------------------------------------------------------------
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
@@ -652,7 +389,28 @@ END FUNCTION LagrangeCoeff_Quadrangle2
END INTERFACE LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
+! LagrangeCoeff_Quadrangle_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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@LagrangeMethods
!----------------------------------------------------------------------------
INTERFACE LagrangeCoeff_Quadrangle
@@ -671,17 +429,33 @@ END FUNCTION LagrangeCoeff_Quadrangle3
END INTERFACE LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
+! LagrangeCoeff_Quadrangle_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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@LagrangeMethods
!----------------------------------------------------------------------------
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(:, :)
@@ -705,22 +479,39 @@ END FUNCTION LagrangeCoeff_Quadrangle4
END INTERFACE LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
+! LagrangeCoeff_Quadrangle_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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@LagrangeMethods
!----------------------------------------------------------------------------
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 +520,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,58 +544,871 @@ END FUNCTION LagrangeCoeff_Quadrangle5
END INTERFACE LagrangeCoeff_Quadrangle
!----------------------------------------------------------------------------
-! DubinerPolynomial
+! LagrangeCoeff_Quadrangle_@LagrangeMethods
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Dubiner (1991) polynomials on biunit domain
-!
-!# Introduction
-!
-! Forms Dubiner basis on biunit quadrangle domain.
-! This routine is called while forming dubiner basis on triangle domain
-!
-! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points)
-! N = 0.5*(order+1)*(order+2).
-!
-! In this way, ans(j,:) denotes the values of all polynomial at jth point
-!
-! Polynomials are returned in following way:
-!
-!$$
-! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\
-! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\
-! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\
-! \cdots
-! P_{order,0}
-!$$
-!
-! For example for order=3, the polynomials are arranged as:
-!
-!$$
-! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\
-! P_{1,0}, P_{1,1}, P_{1,2} \\
-! P_{2,0}, P_{2,1} \\
-! P_{3,0}
-!$$
-
-INTERFACE Dubiner_Quadrangle
- MODULE PURE FUNCTION Dubiner_Quadrangle1(order, xij) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order of polynomial space
+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 biunit quadrangle, shape functions will be evaluated
- !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points
- REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2)
- !! shape functions
- !! ans(:, j), jth shape functions at all points
- !! ans(j, :), all shape functions at jth point
+ !! 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_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+!> 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
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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@LagrangeMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-04
+! 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)
+ 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), 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
+ !! 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_Quadrangle2
+END INTERFACE LagrangeEvalAll_Quadrangle
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeEvalAll_Quadrangle_
+ MODULE SUBROUTINE LagrangeEvalAll_Quadrangle3_( &
+ order, x, xij, ans, nrow, ncol, coeff, xx, 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
+ !! nrow = number of points of evaluation
+ !! ncol = number of degrees of freedom
+ REAL(DFP), INTENT(INOUT) :: coeff(:, :), xx(:, :)
+ !! Coefficient of Lagrange polynomials, The size is ncol by ncol
+ !! The size of xx is nrow by ncol (it is used internally)
+ !! nrow is number of points of evaluation
+ !! ncol is number of degrees of freedom
+ LOGICAL(LGT) :: 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_Quadrangle3_
+END INTERFACE LagrangeEvalAll_Quadrangle_
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-23
+! 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)
+ 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), 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
+ REAL(DFP) :: 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
+ END FUNCTION LagrangeGradientEvalAll_Quadrangle1
+END INTERFACE LagrangeGradientEvalAll_Quadrangle
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Quadrangle@LagrangeMethods
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! RefElemDomain_Quadrangle@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-03
+! summary: Returns the coordinate of reference element
+
+INTERFACE
+ MODULE FUNCTION RefElemDomain_Quadrangle(baseContinuity, baseInterpol) &
+ RESULT(ans)
+ 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_Quadrangle
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! FacetConnectivity_Quadrangle@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-08-10
+! summary: This function returns the edge connectivity of Quadrangle
+
+INTERFACE
+ MODULE FUNCTION FacetConnectivity_Quadrangle(baseInterpol, baseContinuity) &
+ RESULT(ans)
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: baseInterpol
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: baseContinuity
+ INTEGER(I4B) :: ans(2, 4)
+ !! rows represents the end points of an edges
+ !! columns denote the edge (facet)
+ END FUNCTION FacetConnectivity_Quadrangle
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Quadrangle@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 12 Aug 2022
+! summary: Returns the nodal coordinates of higher order Quadrangle element
+!
+!# Introduction
+!
+!- This function returns the nodal coordinates of higher order
+! Quadrangle element
+!- The coordinates are distributed uniformly
+!- These coordinates can be used to construct lagrange polynomials
+!- The returned coordinates are in $x_{iJ}$ format.
+!- The node numbering is according to Gmsh convention.
+
+INTERFACE EquidistancePoint_Quadrangle
+ MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle1(order, xij) &
+ RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! Nodal coordinates of quadrangle
+ !! number of rows = 2
+ !! number of cols = 4
+ REAL(DFP), ALLOCATABLE :: 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
+ END FUNCTION EquidistancePoint_Quadrangle1
+END INTERFACE EquidistancePoint_Quadrangle
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Quadrangle_@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+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@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 12 Aug 2022
+! summary: Returns the nodal coordinates of higher order Quadrangle element
+!
+!# Introduction
+!
+!- This function returns the nodal coordinates of higher order
+! Quadrangle element
+!- The coordinates are distributed uniformly
+!- These coordinates can be used to construct lagrange polynomials
+!- The returned coordinates are in $x_{iJ}$ format.
+!- The node numbering is according to Gmsh convention.
+
+INTERFACE EquidistancePoint_Quadrangle
+ MODULE RECURSIVE FUNCTION EquidistancePoint_Quadrangle2(p, q, &
+ xij) RESULT(ans)
+ 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), ALLOCATABLE :: 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
+ END FUNCTION EquidistancePoint_Quadrangle2
+END INTERFACE EquidistancePoint_Quadrangle
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Quadrangle_@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+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@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance points in Quadrangle
+!
+!# Introduction
+!
+!- This function returns the equidistance points in Quadrangle
+!- All points are inside the Quadrangle
+
+INTERFACE EquidistanceInPoint_Quadrangle
+ MODULE FUNCTION EquidistanceInPoint_Quadrangle1(order, xij) &
+ RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order
+ REAL(DFP), OPTIONAL, INTENT(IN) :: xij(:, :)
+ !! Nodal coordinates of quadrangle
+ !! number of rows = 2 or 3
+ !! number of cols = 4
+ REAL(DFP), ALLOCATABLE :: 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
+ END FUNCTION EquidistanceInPoint_Quadrangle1
+END INTERFACE EquidistanceInPoint_Quadrangle
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Quadrangle@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 14 Aug 2022
+! summary: Returns equidistance points in Quadrangle
+!
+!# Introduction
+!
+!- This function returns the equidistance points in Quadrangle
+!- All points are inside the Quadrangle
+
+INTERFACE EquidistanceInPoint_Quadrangle
+ MODULE FUNCTION EquidistanceInPoint_Quadrangle2(p, q, xij) &
+ RESULT(ans)
+ 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), ALLOCATABLE :: 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
+ END FUNCTION EquidistanceInPoint_Quadrangle2
+END INTERFACE EquidistanceInPoint_Quadrangle
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Interpolation point
+!
+!# Introduction
+!
+! In this case order is same in both x1 and x2 direction. Therefore,
+! (N+1)**2 grid points are returned.
+!
+! Also in both x1 and x2 same type of grid family will be used.
+!
+!- This routine returns the interplation points on quad
+!- `xij` contains nodal coordinates of quad in xij format.
+!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4
+!- If xij is absent then biunit quad is used
+!- `ipType` is interpolation point type, it can take following values
+!- `Equidistance`, uniformly/evenly distributed points
+!- `GaussLegendreLobatto
+!- `GaussChebyshevLobatto
+!
+!- `layout` specifies the arrangement of points. The nodes are always
+! returned in VEFC format (vertex, edge, face, cell). 1:3 are are
+! vertex points, then edge, and then internal nodes. The internal nodes
+! also follow the same convention. Please read Gmsh manual on this topic.
+!
+! interpolation point type
+! Equidistance
+! GaussLegendre
+! GaussLegendreLobatto
+! GaussLegendreRadauLeft
+! GaussLegendreRadauRight
+! GaussChebyshev1
+! GaussChebyshev1Lobatto
+! GaussChebyshev1RadauLeft
+! GaussChebyshev1RadauRight
+! GaussUltraspherical
+! GaussUltrasphericalLobatto
+! GaussUltrasphericalRadauLeft
+! GaussUltrasphericalRadauRight
+! GaussJacobi
+! GaussJacobiLobatto
+! GaussJacobiRadauLeft
+! GaussJacobiRadauRight
+
+INTERFACE InterpolationPoint_Quadrangle
+ 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
+ !! interpolation point type
+ 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
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! interpolation points in xij format
+ END FUNCTION InterpolationPoint_Quadrangle1
+END INTERFACE InterpolationPoint_Quadrangle
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle_@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+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@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 18 Aug 2022
+! summary: Interpolation point
+!
+!# Introduction
+!
+! In this case order is same in both x1 and x2 direction. Therefore,
+! (N+1)**2 grid points are returned.
+!
+! Also in both x1 and x2 same type of grid family will be used.
+!
+!- This routine returns the interplation points on quad
+!- `xij` contains nodal coordinates of quad in xij format.
+!- SIZE(xij,1) = nsd, and SIZE(xij,2)=4
+!- If xij is absent then biunit quad is used
+!- `ipType` is interpolation point type, it can take following values
+!- `Equidistance`, uniformly/evenly distributed points
+!- `GaussLegendreLobatto
+!- `GaussChebyshevLobatto
+!
+!- `layout` specifies the arrangement of points. The nodes are always
+! returned in VEFC format (vertex, edge, face, cell). 1:3 are are
+! vertex points, then edge, and then internal nodes. The internal nodes
+! also follow the same convention. Please read Gmsh manual on this topic.
+
+INTERFACE InterpolationPoint_Quadrangle
+ 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
+ INTEGER(I4B), INTENT(IN) :: ipType2
+ !! interpolation point type in y direction
+ 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
+ REAL(DFP), ALLOCATABLE :: ans(:, :)
+ !! interpolation points in xij format
+ END FUNCTION InterpolationPoint_Quadrangle2
+END INTERFACE InterpolationPoint_Quadrangle
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle_@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+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_Quadrangle@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-17
+! summary: Convert interpolation point format from IJ to VEFC
+
+INTERFACE
+ MODULE SUBROUTINE IJ2VEFC_Quadrangle(xi, eta, temp, p, q)
+ REAL(DFP), INTENT(IN) :: xi(:, :)
+ REAL(DFP), INTENT(IN) :: eta(:, :)
+ REAL(DFP), INTENT(OUT) :: temp(:, :)
+ INTEGER(I4B), INTENT(IN) :: p
+ INTEGER(I4B), INTENT(IN) :: q
+ END SUBROUTINE IJ2VEFC_Quadrangle
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! IJ2VEFC_Quadrangle@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-17
+! summary: Convert format from IJ to VEFC
+
+INTERFACE
+ 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(:, :)
+ INTEGER(I4B), INTENT(IN) :: p
+ INTEGER(I4B), INTENT(IN) :: q
+ INTEGER(I4B), INTENT(IN) :: startNode
+ END SUBROUTINE IJ2VEFC_Quadrangle_Clockwise
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! IJ2VEFC_Quadrangle@InterpolationPointMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-07-17
+! summary: Convert format from IJ to VEFC
+
+INTERFACE
+ 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(:, :)
+ INTEGER(I4B), INTENT(IN) :: p
+ INTEGER(I4B), INTENT(IN) :: q
+ INTEGER(I4B), INTENT(IN) :: startNode
+ END SUBROUTINE IJ2VEFC_Quadrangle_AntiClockwise
+END INTERFACE
+
+!----------------------------------------------------------------------------
+! DubinerPolynomial@DubinerMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Dubiner (1991) polynomials on biunit domain
+!
+!# Introduction
+!
+! Forms Dubiner basis on biunit quadrangle domain.
+! This routine is called while forming dubiner basis on triangle domain
+!
+! The shape of `ans` is (M,N), where M=SIZE(xij,2) (number of points)
+! N = 0.5*(order+1)*(order+2).
+!
+! In this way, ans(j,:) denotes the values of all polynomial at jth point
+!
+! Polynomials are returned in following way:
+!
+!$$
+! P_{0,0}, P_{0,1}, \cdots , P_{0,order} \\
+! P_{1,0}, P_{1,1}, \cdots , P_{1,order-1} \\
+! P_{2,0}, P_{2,1}, \cdots , P_{2,order-2} \\
+! \cdots
+! P_{order,0}
+!$$
+!
+! For example for order=3, the polynomials are arranged as:
+!
+!$$
+! P_{0,0}, P_{0,1}, P_{0,2}, P_{0,3} \\
+! P_{1,0}, P_{1,1}, P_{1,2} \\
+! P_{2,0}, P_{2,1} \\
+! P_{3,0}
+!$$
+
+INTERFACE Dubiner_Quadrangle
+ MODULE PURE FUNCTION Dubiner_Quadrangle1(order, xij) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order of polynomial space
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in biunit quadrangle, shape functions will be evaluated
+ !! at these points. SIZE(xij,1) = 2, and SIZE(xij, 2) = number of points
+ REAL(DFP) :: ans(SIZE(xij, 2), (order + 1) * (order + 2) / 2)
+ !! shape functions
+ !! ans(:, j), jth shape functions at all points
+ !! ans(j, :), all shape functions at jth point
END FUNCTION Dubiner_Quadrangle1
END INTERFACE Dubiner_Quadrangle
!----------------------------------------------------------------------------
-! DubinerPolynomial
+! DubinerPolynomial@DubinerMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -865,7 +1461,7 @@ END SUBROUTINE Dubiner_Quadrangle1_
END INTERFACE Dubiner_Quadrangle_
!----------------------------------------------------------------------------
-! DubinerPolynomial
+! DubinerPolynomial@DubinerMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -895,7 +1491,7 @@ END FUNCTION Dubiner_Quadrangle2
END INTERFACE Dubiner_Quadrangle
!----------------------------------------------------------------------------
-! DubinerPolynomial
+! DubinerPolynomial@DubinerMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -927,7 +1523,7 @@ END SUBROUTINE Dubiner_Quadrangle2_
END INTERFACE Dubiner_Quadrangle_
!----------------------------------------------------------------------------
-! DubinerGradient
+! DubinerGradient@DubinerMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -971,8 +1567,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
@@ -980,7 +1576,7 @@ END FUNCTION DubinerGradient_Quadrangle1
END INTERFACE DubinerGradient_Quadrangle
!----------------------------------------------------------------------------
-! DubinerGradient
+! DubinerGradient@DubinerMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1037,7 +1633,7 @@ END SUBROUTINE DubinerGradient_Quadrangle1_
END INTERFACE DubinerGradient_Quadrangle_
!----------------------------------------------------------------------------
-! TensorProdBasis_Quadrangle
+! TensorProdBasis_Quadrangle@TensorProdMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1050,19 +1646,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 +1656,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"
@@ -1107,7 +1684,49 @@ END FUNCTION TensorProdBasis_Quadrangle1
END INTERFACE OrthogonalBasis_Quadrangle
!----------------------------------------------------------------------------
-! TensorProdBasis_Quadrangle
+! TensorProdBasis_Quadrangle@TensorProdMethods
+!----------------------------------------------------------------------------
+
+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@TensorProdMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1121,20 +1740,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
@@ -1181,7 +1788,52 @@ END FUNCTION TensorProdBasis_Quadrangle2
END INTERFACE OrthogonalBasis_Quadrangle
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle
+! TensorProdBasis_Quadrangle@TensorProdMethods
+!----------------------------------------------------------------------------
+
+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@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1189,8 +1841,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,70 +1850,54 @@ END FUNCTION VertexBasis_Quadrangle1
END INTERFACE VertexBasis_Quadrangle
!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle
+! VertexBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
-!> 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@HierarchicalMethods
!----------------------------------------------------------------------------
!> 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@HierarchicalMethods
!----------------------------------------------------------------------------
-!> 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
+! VerticalEdgeBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1279,7 +1914,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
@@ -1294,49 +1929,29 @@ END FUNCTION VerticalEdgeBasis_Quadrangle
END INTERFACE
!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-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
-
-!----------------------------------------------------------------------------
-!
+! VerticalEdgeBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
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
!----------------------------------------------------------------------------
-! HorizontalEdgeBasis_Quadrangle
+! HorizontalEdgeBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1351,7 +1966,7 @@ END FUNCTION VerticalEdgeBasisGradient_Quadrangle2
INTERFACE
MODULE PURE FUNCTION HorizontalEdgeBasis_Quadrangle(pe3, pe4, x, y) &
- & RESULT(ans)
+ 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,43 +1982,22 @@ 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
!----------------------------------------------------------------------------
-! CellBasis_Quadrangle
+! CellBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1423,49 +2017,30 @@ MODULE PURE FUNCTION CellBasis_Quadrangle(pb, qb, x, y) RESULT(ans)
REAL(DFP), INTENT(IN) :: x(:), y(:)
!! point of evaluation
REAL(DFP) :: ans(SIZE(x), (pb - 1) * (qb - 1))
- END FUNCTION CellBasis_Quadrangle
-END INTERFACE
-
-!----------------------------------------------------------------------------
-! CellBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-INTERFACE
- MODULE PURE FUNCTION CellBasis_Quadrangle2(pb, qb, L1, L2) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: pb
- !! order on bottom vertical edge (e3), 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) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1))
- END FUNCTION CellBasis_Quadrangle2
+ END FUNCTION CellBasis_Quadrangle
END INTERFACE
!----------------------------------------------------------------------------
-! CellBasisGradient_Quadrangle
+! CellBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
INTERFACE
- MODULE PURE FUNCTION CellBasisGradient_Quadrangle2( &
- & pb, &
- & qb, &
- & L1, &
- & L2, &
- & dL1, &
- & dL2) 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) :: dL1(1:, 0:), dL2(1:, 0:)
- REAL(DFP) :: ans(SIZE(L1, 1), (pb - 1) * (qb - 1), 2)
- END FUNCTION CellBasisGradient_Quadrangle2
+ REAL(DFP), INTENT(IN) :: x(:), y(:)
+ !! point of evaluation
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(x), (pb - 1) * (qb - 1))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE CellBasis_Quadrangle_
END INTERFACE
!----------------------------------------------------------------------------
-! HeirarchicalBasis_Quadrangle
+! HeirarchicalBasis_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1486,7 +2061,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
@@ -1508,7 +2083,35 @@ END FUNCTION HeirarchicalBasis_Quadrangle1
END INTERFACE HeirarchicalBasis_Quadrangle
!----------------------------------------------------------------------------
-! HeirarchicalBasis_Quadrangle
+! HeirarchicalBasis_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1534,152 +2137,438 @@ END FUNCTION HeirarchicalBasis_Quadrangle2
END INTERFACE HeirarchicalBasis_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeEvalAll_Quadrangle
+! HeirarchicalBasis_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-04
-! summary: Evaluate all Lagrange polynomial of order n at single points
+! date: 27 Oct 2022
+! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle
+!
+!# Introduction
+!
+! This function returns the modal basis on orthogonal polynomial
+! The modal function in 1D is given by scaled Lobatto polynomial.
+! These modal functions are orthogonal with respect to H1 seminorm.
+! However, these modal function are not orthogonal withrespect to L2 norm.
+!
+! Bubble function in 1D is proportional to Jacobi polynomial with
+! alpha=beta=1. Equivalently, these bubble functions are proportional to
+! Ultraspherical polynomials with lambda = 3/2.
-INTERFACE 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 HeirarchicalBasisGradient_Quadrangle
+ 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
+ !! order of interpolation inside the quadrangle in x2 direction
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order of interpolation on edge e3 (bottom) in x1 direction
+ INTEGER(I4B), INTENT(IN) :: pe4
+ !! order of interpolation on edge e4 (top) in x1 direction
+ INTEGER(I4B), INTENT(IN) :: qe1
+ !! order of interpolation on edge e1 (left) in y1 direction
+ INTEGER(I4B), INTENT(IN) :: qe2
+ !! order of interpolation on edge e2 (right) in y1 direction
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ REAL(DFP) :: ans(SIZE(xij, 2), &
+ & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1, 2)
+ END FUNCTION HeirarchicalBasisGradient_Quadrangle1
+END INTERFACE HeirarchicalBasisGradient_Quadrangle
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle
+
+INTERFACE HeirarchicalBasisGradient_Quadrangle
+ 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
+ !! order of interpolation inside the quadrangle in x2 direction
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2)
+ END FUNCTION HeirarchicalBasisGradient_Quadrangle2
+END INTERFACE HeirarchicalBasisGradient_Quadrangle
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+!> 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@HierarchicalMethods
+!----------------------------------------------------------------------------
+
+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@TensorProdMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! 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)
+ INTEGER(I4B), INTENT(IN) :: p
+ !! highest order in x1 direction
+ INTEGER(I4B), INTENT(IN) :: q
+ !! highest order in x2 direction
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points of evaluation in xij format
+ INTEGER(I4B), INTENT(IN) :: 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"
+ REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2)
+ !!
+ END FUNCTION TensorProdBasisGradient_Quadrangle1
+END INTERFACE TensorProdBasisGradient_Quadrangle
+
+INTERFACE OrthogonalBasisGradient_Quadrangle
+ MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1
+END INTERFACE OrthogonalBasisGradient_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeEvalAll_Quadrangle
+! TensorProdBasisGradient_Quadrangle@TensorProdMethods
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-07-04
-! 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)
- 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), 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
+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
- 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_Quadrangle2
-END INTERFACE LagrangeEvalAll_Quadrangle
+ 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_
+
+!----------------------------------------------------------------------------
+! QuadratureNumber_Quadrangle@QuadratureMethods
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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)
+ END FUNCTION QuadratureNumber_Quadrangle
+END INTERFACE
!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle
+! QuadraturePoint_Quadrangle@QuadratureMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2023-07-19
! summary: Returns quadrature points on reference quadrangle
+!
+!# Introduction
+!
+! quadType can take the following values:
+!
+! GaussLegendre
+! GaussLegendreLobatto
+! GaussLegendreRadauLeft
+! GaussLegendreRadauRight
+! GaussChebyshev1
+! GaussChebyshev1Lobatto
+! GaussChebyshev1RadauLeft
+! GaussChebyshev1RadauRight
+! GaussUltraspherical
+! GaussUltrasphericalLobatto
+! GaussUltrasphericalRadauLeft
+! GaussUltrasphericalRadauRight
+! GaussJacobi
+! GaussJacobiLobatto
+! GaussJacobiRadauLeft
+! GaussJacobiRadauRight
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
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
@@ -1694,40 +2583,21 @@ END FUNCTION QuadraturePoint_Quadrangle1
END INTERFACE QuadraturePoint_Quadrangle
!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle
+! QuadraturePoint_Quadrangle@QuadratureMethods
!----------------------------------------------------------------------------
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
+ !! quadrature point type in x direction, see above
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
@@ -1748,7 +2618,7 @@ END FUNCTION QuadraturePoint_Quadrangle2
END INTERFACE QuadraturePoint_Quadrangle
!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle
+! QuadraturePoint_Quadrangle@QuadratureMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1757,31 +2627,13 @@ 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, see above
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
@@ -1796,41 +2648,28 @@ END FUNCTION QuadraturePoint_Quadrangle3
END INTERFACE QuadraturePoint_Quadrangle
!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle
+! QuadraturePoint_Quadrangle@QuadratureMethods
!----------------------------------------------------------------------------
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
@@ -1851,192 +2690,51 @@ END FUNCTION QuadraturePoint_Quadrangle4
END INTERFACE QuadraturePoint_Quadrangle
!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-23
-! 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)
- 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), 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
- REAL(DFP) :: 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
- END FUNCTION LagrangeGradientEvalAll_Quadrangle1
-END INTERFACE LagrangeGradientEvalAll_Quadrangle
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle
-!
-!# Introduction
-!
-! This function returns the modal basis on orthogonal polynomial
-! The modal function in 1D is given by scaled Lobatto polynomial.
-! These modal functions are orthogonal with respect to H1 seminorm.
-! However, these modal function are not orthogonal withrespect to L2 norm.
-!
-! Bubble function in 1D is proportional to Jacobi polynomial with
-! alpha=beta=1. Equivalently, these bubble functions are proportional to
-! Ultraspherical polynomials with lambda = 3/2.
-
-INTERFACE HeirarchicalBasisGradient_Quadrangle
- 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
- !! order of interpolation inside the quadrangle in x2 direction
- INTEGER(I4B), INTENT(IN) :: pe3
- !! order of interpolation on edge e3 (bottom) in x1 direction
- INTEGER(I4B), INTENT(IN) :: pe4
- !! order of interpolation on edge e4 (top) in x1 direction
- INTEGER(I4B), INTENT(IN) :: qe1
- !! order of interpolation on edge e1 (left) in y1 direction
- INTEGER(I4B), INTENT(IN) :: qe2
- !! order of interpolation on edge e2 (right) in y1 direction
- REAL(DFP), INTENT(IN) :: xij(:, :)
- !! points of evaluation in xij format
- REAL(DFP) :: ans(SIZE(xij, 2), &
- & pb * qb - pb - qb + pe3 + pe4 + qe1 + qe2 + 1, 2)
- END FUNCTION HeirarchicalBasisGradient_Quadrangle1
-END INTERFACE HeirarchicalBasisGradient_Quadrangle
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! summary: Evaluate all modal basis (heirarchical polynomial) on quadrangle
-
-INTERFACE HeirarchicalBasisGradient_Quadrangle
- 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
- !! order of interpolation inside the quadrangle in x2 direction
- REAL(DFP), INTENT(IN) :: xij(:, :)
- !! points of evaluation in xij format
- REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2)
- END FUNCTION HeirarchicalBasisGradient_Quadrangle2
-END INTERFACE HeirarchicalBasisGradient_Quadrangle
-
-!----------------------------------------------------------------------------
-! TensorProdBasisGradient_Quadrangle
+! QuadraturePoint_Quadrangle@QuadratureMethods
!----------------------------------------------------------------------------
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! 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)
- INTEGER(I4B), INTENT(IN) :: p
- !! highest order in x1 direction
- INTEGER(I4B), INTENT(IN) :: q
- !! highest order in x2 direction
- REAL(DFP), INTENT(IN) :: xij(:, :)
- !! points of evaluation in xij format
- INTEGER(I4B), INTENT(IN) :: 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
+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
- !! alpha1 needed when basisType1 "Jacobi"
+ !! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta1
- !! beta1 is needed when basisType1 is "Jacobi"
+ !! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda1
- !! lambda1 is needed when basisType1 is "Ultraspherical"
+ !! Ultraspherical parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha2
- !! alpha2 needed when basisType2 is "Jacobi"
+ !! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: beta2
- !! beta2 needed when basisType2 is "Jacobi"
+ !! Jacobi parameter
REAL(DFP), OPTIONAL, INTENT(IN) :: lambda2
- !! lambda2 is needed when basisType2 is "Ultraspherical"
- REAL(DFP) :: ans(SIZE(xij, 2), (p + 1) * (q + 1), 2)
- !!
- END FUNCTION TensorProdBasisGradient_Quadrangle1
-END INTERFACE TensorProdBasisGradient_Quadrangle
+ !! 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_
-INTERFACE OrthogonalBasisGradient_Quadrangle
- MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1
-END INTERFACE OrthogonalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END MODULE QuadrangleInterpolationUtility
diff --git a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90 b/src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90
similarity index 90%
rename from src/modules/Geometry/src/ReferenceQuadrangle_Method.F90
rename to src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90
index 09f3e2cd3..fa8360e5f 100644
--- a/src/modules/Geometry/src/ReferenceQuadrangle_Method.F90
+++ b/src/modules/Quadrangle/src/ReferenceQuadrangle_Method.F90
@@ -20,11 +20,14 @@
! 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
@@ -57,13 +60,13 @@ MODULE ReferenceQuadrangle_Method
INTEGER(I4B), PARAMETER :: MaxOrder_Quadrangle = 2_I4B
#endif
-INTEGER(I4B), PUBLIC, PARAMETER :: HelpFaceData_Quadrangle(3, 4) = &
- & RESHAPE([ &
- & 2, 3, 4, &
- & 3, 4, 1, &
- & 4, 1, 2, &
- & 1, 2, 3 &
- & ], [3, 4])
+INTEGER(I4B), PUBLIC, PARAMETER :: HelpFaceData_Quadrangle(3, 4) = &
+ RESHAPE([ &
+ 2, 3, 4, &
+ 3, 4, 1, &
+ 4, 1, 2, &
+ 1, 2, 3 &
+ ], [3, 4])
#ifdef QUADRANGLE_EDGE_CON_DEFAULT_OPT_1
INTEGER(I4B), PARAMETER :: DEFAULT_OPT_QUADRANGLE_EDGE_CON = 1_I4B
@@ -254,8 +257,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 +290,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 +451,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(:)
@@ -465,9 +468,9 @@ END SUBROUTINE FaceShapeMetaData_Quadrangle
! date: 2024-04-19
! summary: Returns the element type of each face
-INTERFACE
-MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, opt, &
- tFaceNodes)
+INTERFACE GetFaceElemType_Quadrangle
+ MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle1(elemType, faceElemType, &
+ opt, tFaceNodes)
INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
!! name of element
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
@@ -478,7 +481,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle(elemType, faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- END SUBROUTINE GetFaceElemType_Quadrangle
-END INTERFACE
+ END SUBROUTINE GetFaceElemType_Quadrangle1
+END INTERFACE GetFaceElemType_Quadrangle
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Quadrangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-04-19
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Quadrangle
+ MODULE PURE SUBROUTINE GetFaceElemType_Quadrangle2( &
+ elemType, localFaceNumber, faceElemType, opt, tFaceNodes)
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! name of element
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Element names of faces
+ INTEGER(I4B), INTENT(INOUT) :: tFaceNodes
+ !! Total number of nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Quadrangle2
+END INTERFACE GetFaceElemType_Quadrangle
END MODULE ReferenceQuadrangle_Method
diff --git a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90 b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90
index 8ba04ee10..103ff5612 100755
--- a/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90
+++ b/src/modules/QuadraturePoint/src/QuadraturePoint_Method.F90
@@ -19,22 +19,35 @@
! 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 :: Set
PUBLIC :: Initiate
+PUBLIC :: InitiateFacetQuadrature
+PUBLIC :: Copy
+PUBLIC :: ASSIGNMENT(=)
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 :: QuadraturePoint_ToInteger
PUBLIC :: QuadraturePointNameToId
PUBLIC :: MdEncode
@@ -46,12 +59,12 @@ MODULE QuadraturePoint_Method
! date: 2023-08-06
! summary: Quadrature point name to quadrature point id
-INTERFACE
+INTERFACE QuadraturePoint_ToInteger
MODULE FUNCTION QuadraturePointNameToId(name) RESULT(ans)
CHARACTER(*), INTENT(IN) :: name
INTEGER(I4B) :: ans
END FUNCTION QuadraturePointNameToId
-END INTERFACE
+END INTERFACE QuadraturePoint_ToInteger
!----------------------------------------------------------------------------
! QuadratuePointIdToName@ConstructorMethods
@@ -59,32 +72,95 @@ END FUNCTION QuadraturePointNameToId
!> author: Vikas Sharma, Ph. D.
! date: 2023-08-06
-! summary: Quadrature point name to quadrature point id
+! summary: Convert Quadrature point from int id to string name
INTERFACE
- MODULE FUNCTION QuadraturePointIdToName(name) RESULT(ans)
+ MODULE FUNCTION QuadraturePointIdToName(name, isUpper) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: name
TYPE(String) :: ans
+ LOGICAL, INTENT(IN), OPTIONAL :: isUpper
END FUNCTION QuadraturePointIdToName
END INTERFACE
+!----------------------------------------------------------------------------
+! QuadraturePoint_ToChar@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-06-18
+! summary: Convert Quadrature poitn from int id to char name
+
+INTERFACE
+ MODULE FUNCTION QuadraturePoint_ToChar(name, isUpper) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: name
+ LOGICAL(LGT), OPTIONAL, INTENT(IN) :: isUpper
+ CHARACTER(:), ALLOCATABLE :: 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
+
+!----------------------------------------------------------------------------
+! Copy@ConstructorMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 23 July 2021
+! summary: This routine Initiates the quadrature points
+
+INTERFACE Initiate
+ MODULE PURE SUBROUTINE obj_Copy(obj, obj2)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj2
+ END SUBROUTINE obj_Copy
+END INTERFACE Initiate
+
+INTERFACE Copy
+ MODULE PROCEDURE obj_Copy
+END INTERFACE Copy
+
+INTERFACE ASSIGNMENT(=)
+ MODULE PROCEDURE obj_Copy
+END INTERFACE ASSIGNMENT(=)
+
!----------------------------------------------------------------------------
! 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 +169,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 +181,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 +190,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 +207,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,17 +227,23 @@ 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 from number of IP
+!
+!# Introduction
+!
+! This routine is used to initiate the quadrature points from number of
+! integration points.
+! 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
!! Reference element
INTEGER(I4B), INTENT(IN) :: nips(1)
- !! order of integrand
+ !! number of quadrature points
CHARACTER(*), INTENT(IN) :: quadratureType
!! Total number quadrature points
REAL(DFP), OPTIONAL, INTENT(IN) :: alpha
@@ -169,7 +252,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 +264,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 +273,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 +292,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,7 +315,7 @@ 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
!----------------------------------------------------------------------------
@@ -264,19 +324,14 @@ END SUBROUTINE quad_initiate6
!> 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 +343,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 +357,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 +366,14 @@ 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 +386,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 +400,178 @@ 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-05-21
+! summary: This routine Initiates the quadrature points
+!
+!# Introduction
+!
+! This routine is used to initiate the quadrature points from order of
+! of integrand.
+! This subroutine does not require formation of reference element.
+! This routine calls obj_Initiate11 method.
+
+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 for reference element
+ !! unit or biunit
+ 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-05-21
+! summary: This routine Initiates the quadrature points
+!
+!# Introduction
+!
+! This routine is used to initiate the quadrature points from number of
+! integration points.
+! This subroutine does not require formation of reference element.
+! This routine calls obj_Initiate12 method.
+
+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, reference element
+ !! unit or biunit
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! Number of integration points
+ !! 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
+
+!----------------------------------------------------------------------------
+! Initiate@ConstructorMethods
+!----------------------------------------------------------------------------
+
+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 +580,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 +599,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 +614,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 +627,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,13 +643,42 @@ 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_GetTotalQuadraturePoints1(obj) RESULT(ans)
+ TYPE(QuadraturePoint_), INTENT(IN) :: obj
INTEGER(I4B) :: ans
- END FUNCTION quad_getTotalQuadraturepoints
+ END FUNCTION obj_GetTotalQuadraturePoints1
END INTERFACE GetTotalQuadraturepoints
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE GetTotalQuadraturePoints
+ MODULE FUNCTION obj_GetTotalQuadraturePoints2(elemType, p, q, r, &
+ quadratureType1, &
+ quadratureType2, &
+ quadratureType3) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: elemtype
+ !! Reference-element
+ 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
+ INTEGER(I4B) :: ans
+ END FUNCTION obj_GetTotalQuadraturePoints2
+END INTERFACE GetTotalQuadraturePoints
+
!----------------------------------------------------------------------------
! GetQuadraturePoint@GetMethods
!----------------------------------------------------------------------------
@@ -452,21 +687,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 +707,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 +766,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 +785,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 +801,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
!----------------------------------------------------------------------------
@@ -772,6 +1039,223 @@ END FUNCTION QuadraturePoint_MdEncode
! END FUNCTION getGaussLegendreRadauRightQP3
! END INTERFACE GaussLegendreRadauRightQuadrature
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature@FacetQuadratureMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-05-21
+! summary: This routine Initiates the quadrature points
+!
+!# Introduction
+!
+! This routine is used to initiate the quadrature points from order of
+! of integrand.
+! This subroutine does not require formation of reference element.
+! This routine calls obj_Initiate11 method.
+
+INTERFACE InitiateFacetQuadrature
+ MODULE SUBROUTINE obj_InitiateFacetQuadrature1(obj, facetQuad, &
+ localFaceNumber, elemType, &
+ domainName, order, &
+ quadratureType, &
+ alpha, beta, lambda, xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Quadrature point in the cell
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad
+ !! Quadrature point on the local face
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element name
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain name for reference element
+ !! unit or biunit
+ 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), INTENT(IN) :: xij(:, :)
+ END SUBROUTINE obj_InitiateFacetQuadrature1
+END INTERFACE InitiateFacetQuadrature
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature@FacetQuadratureMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-05-21
+! summary: This routine Initiates the quadrature points
+
+INTERFACE InitiateFacetQuadrature
+ MODULE SUBROUTINE obj_InitiateFacetQuadrature2(obj, facetQuad, &
+ localFaceNumber, elemType, &
+ domainName, nips, &
+ quadratureType, alpha, &
+ beta, lambda, xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Quadrature point in the cell
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad
+ !! Quadrature point on the local facet
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(IN) :: elemType
+ !! element name
+ CHARACTER(*), INTENT(IN) :: domainName
+ !! domain name, reference element
+ !! unit or biunit
+ INTEGER(I4B), INTENT(IN) :: nips(1)
+ !! Number of integration points
+ !! 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), INTENT(IN) :: xij(:, :)
+ END SUBROUTINE obj_InitiateFacetQuadrature2
+END INTERFACE InitiateFacetQuadrature
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature@FacetQuadratureMethods
+!----------------------------------------------------------------------------
+
+INTERFACE InitiateFacetQuadrature
+ MODULE SUBROUTINE obj_InitiateFacetQuadrature3(obj, facetQuad, &
+ localFaceNumber, elemType, &
+ domainName, p, q, r, &
+ quadratureType1, &
+ quadratureType2, &
+ quadratureType3, &
+ alpha1, beta1, lambda1, &
+ alpha2, beta2, lambda2, &
+ alpha3, beta3, lambda3, &
+ xij)
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: obj
+ !! Quadrature point in the cell
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad
+ !! Quadrature point on the local face element
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local facet number
+ 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), INTENT(IN) :: xij(:, :)
+ END SUBROUTINE obj_InitiateFacetQuadrature3
+END INTERFACE InitiateFacetQuadrature
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature@FacetQuadratureMethods
+!----------------------------------------------------------------------------
+
+INTERFACE InitiateFacetQuadrature
+ MODULE SUBROUTINE obj_InitiateFacetQuadrature4(obj, facetQuad, &
+ localFaceNumber, &
+ 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
+ TYPE(QuadraturePoint_), INTENT(INOUT) :: facetQuad
+ !! Quadrature point on the local face element
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local facet number
+ 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), INTENT(IN) :: xij(:, :)
+ !! coordinates of reference element
+ END SUBROUTINE obj_InitiateFacetQuadrature4
+END INTERFACE InitiateFacetQuadrature
+
+!----------------------------------------------------------------------------
+! Set@SetMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-29
+! summary: This routine sets the quadrature points
+! We do not allocate anything here
+
+INTERFACE Set
+ MODULE PURE SUBROUTINE obj_Set1(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 obj_Set1
+END INTERFACE Set
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/modules/Random/src/Random_Method.F90 b/src/modules/Random/src/Random_Method.F90
index c1bc307e0..7c45cc0c7 100644
--- a/src/modules/Random/src/Random_Method.F90
+++ b/src/modules/Random/src/Random_Method.F90
@@ -21,6 +21,16 @@ MODULE Random_Method
IMPLICIT NONE
PRIVATE
+PUBLIC :: Initiate
+PUBLIC :: RandomValue
+PUBLIC :: SaveRandom
+PUBLIC :: uniformRandom
+PUBLIC :: rvec_uniform_01
+PUBLIC :: rvec_uniform_ab
+PUBLIC :: rvec_uniform_unit
+PUBLIC :: rvec_normal_01
+PUBLIC :: r8_uniform_01
+
!----------------------------------------------------------------------------
! Initiate@Constructor
!----------------------------------------------------------------------------
@@ -35,8 +45,6 @@ END SUBROUTINE initRandom
MODULE PROCEDURE initRandom
END INTERFACE Initiate
-PUBLIC :: Initiate
-
!----------------------------------------------------------------------------
! getRandom
!----------------------------------------------------------------------------
@@ -53,8 +61,6 @@ END FUNCTION getRandom
MODULE PROCEDURE getRandom
END INTERFACE RandomValue
-PUBLIC :: RandomValue
-
!----------------------------------------------------------------------------
! SaveRandom
!----------------------------------------------------------------------------
@@ -65,8 +71,6 @@ MODULE SUBROUTINE SaveRandom(obj)
END SUBROUTINE SaveRandom
END INTERFACE
-PUBLIC :: SaveRandom
-
!----------------------------------------------------------------------------
! UniformRandom
!----------------------------------------------------------------------------
@@ -79,8 +83,6 @@ MODULE FUNCTION uniformRandom(obj, From, To) RESULT(Ans)
END FUNCTION uniformRandom
END INTERFACE
-PUBLIC :: uniformRandom
-
INTERFACE RandomValue
MODULE PROCEDURE uniformRandom
END INTERFACE RandomValue
@@ -175,8 +177,6 @@ MODULE PURE FUNCTION rvec_uniform_01(n, seed) RESULT(r)
END FUNCTION rvec_uniform_01
END INTERFACE
-PUBLIC :: rvec_uniform_01
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -195,8 +195,6 @@ MODULE PURE FUNCTION rvec_uniform_ab(n, a, b, seed) RESULT(r)
END FUNCTION rvec_uniform_ab
END INTERFACE
-PUBLIC :: rvec_uniform_ab
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -213,8 +211,6 @@ MODULE PURE FUNCTION rvec_uniform_unit(m, seed) RESULT(w)
END FUNCTION rvec_uniform_unit
END INTERFACE
-PUBLIC :: rvec_uniform_unit
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -281,8 +277,6 @@ MODULE PURE FUNCTION rvec_normal_01(n, seed) RESULT(x)
END FUNCTION rvec_normal_01
END INTERFACE
-PUBLIC :: rvec_normal_01
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
@@ -329,8 +323,6 @@ MODULE PURE FUNCTION r8_uniform_01(seed) RESULT(ans)
END FUNCTION r8_uniform_01
END INTERFACE
-PUBLIC :: r8_uniform_01
-
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
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 31b2f8bff..e0ea0f749 100644
--- a/src/modules/RealVector/src/RealVector_AddMethods.F90
+++ b/src/modules/RealVector/src/RealVector_AddMethods.F90
@@ -25,503 +25,527 @@ MODULE RealVector_AddMethods
PUBLIC :: Add
!----------------------------------------------------------------------------
-! set@SetMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
! summary: Add all values to given scalar
+!
+!# Introduction
+!
+!@note
+! We call F77_AXPY in this method
+!@endnote
INTERFACE Add
- MODULE SUBROUTINE obj_add1(obj, VALUE, scale)
+ MODULE SUBROUTINE obj_Add1(obj, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add1
+ END SUBROUTINE obj_Add1
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@SetMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
! summary: Add all values by given vector
+!
+!@note
+! We call F95_AXPY in this method
+!@endnote
INTERFACE Add
- MODULE SUBROUTINE obj_add2(obj, VALUE, scale)
+ MODULE SUBROUTINE obj_Add2(obj, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
+ !! obj = obj + scale*VALUE
REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! Size of value should be equal to the size of obj
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add2
+ !! scale
+ END SUBROUTINE obj_Add2
END INTERFACE Add
!----------------------------------------------------------------------------
-! add@AddMethod
+! add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 Jan 2022
-! summary: set selected values
+! summary: Add selected values
INTERFACE Add
- MODULE SUBROUTINE obj_add3(obj, nodenum, VALUE, scale)
+ MODULE SUBROUTINE obj_Add3(obj, nodenum, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add3
+ END SUBROUTINE obj_Add3
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add4(obj, nodenum, VALUE, scale)
+ MODULE SUBROUTINE obj_Add4(obj, nodenum, VALUE, scale)
TYPE(Realvector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add4
+ END SUBROUTINE obj_Add4
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@SetMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 5 Jan 2022
-! summary: set selected values
+! summary: Add selected values
INTERFACE Add
- MODULE SUBROUTINE obj_add5(obj, nodenum, VALUE, scale)
+ MODULE SUBROUTINE obj_Add5(obj, nodenum, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add5
+ END SUBROUTINE obj_Add5
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@SetMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
! summary: Add range of values to a scalar
+!
+!@note
+! We call F77_AXPY in this method
+!@endnote
INTERFACE Add
- MODULE SUBROUTINE obj_add6(obj, istart, iend, stride, VALUE, scale)
+ MODULE SUBROUTINE obj_Add6(obj, istart, iend, stride, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to be added
REAL(DFP), INTENT(IN) :: VALUE
+ !! scalar value
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add6
+ !! scale
+ END SUBROUTINE obj_Add6
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@SetMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
! summary: Add range of values to a vector
+!
+!@note!
+! We call F77_AXPY
+!@endnote
INTERFACE Add
- MODULE SUBROUTINE obj_add7(obj, istart, iend, stride, VALUE, scale)
+ MODULE SUBROUTINE obj_Add7(obj, istart, iend, stride, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add7
+ END SUBROUTINE obj_Add7
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add8(obj, dofobj, nodenum, VALUE, &
- & scale, conversion)
+ 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
INTEGER(I4B), INTENT(IN) :: conversion(1)
- END SUBROUTINE obj_add8
+ END SUBROUTINE obj_Add8
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add9(obj, dofobj, nodenum, VALUE, &
- & scale)
+ 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
- END SUBROUTINE obj_add9
+ END SUBROUTINE obj_Add9
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add10(obj, dofobj, nodenum, VALUE, &
- & scale, idof)
+ 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
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE obj_add10
+ END SUBROUTINE obj_Add10
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add11(obj, dofobj, nodenum, VALUE, &
- & scale, idof)
+ 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
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE obj_add11
+ END SUBROUTINE obj_Add11
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add12(obj, dofobj, nodenum, VALUE, &
- & scale, ivar, idof)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE obj_add12
+ END SUBROUTINE obj_Add12
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add13(obj, dofobj, nodenum, VALUE, &
- & scale, ivar, idof)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE obj_add13
+ END SUBROUTINE obj_Add13
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add14(obj, dofobj, nodenum, VALUE, &
- & scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE obj_add14
+ END SUBROUTINE obj_Add14
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add15(obj, dofobj, nodenum, VALUE, &
- & scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE obj_add15
+ END SUBROUTINE obj_Add15
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add16(obj, dofobj, nodenum, VALUE, &
- & scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo(:)
- END SUBROUTINE obj_add16
+ END SUBROUTINE obj_Add16
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add17(obj, dofobj, nodenum, VALUE, &
- & scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo(:)
- END SUBROUTINE obj_add17
+ END SUBROUTINE obj_Add17
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add18(obj, dofobj, nodenum, VALUE, &
- scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE obj_add18
+ END SUBROUTINE obj_Add18
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Add2]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add19(obj, dofobj, nodenum, VALUE, &
- scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE obj_add19
+ END SUBROUTINE obj_Add19
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add20(obj, dofobj, nodenum, VALUE, &
- scale)
+ 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
- END SUBROUTINE obj_add20
+ END SUBROUTINE obj_Add20
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add21(obj, dofobj, nodenum, VALUE, &
- scale, idof)
+ 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
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE obj_add21
+ END SUBROUTINE obj_Add21
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add22(obj, dofobj, nodenum, VALUE, &
- scale, ivar, idof)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: idof
- END SUBROUTINE obj_add22
+ END SUBROUTINE obj_Add22
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add23(obj, dofobj, nodenum, VALUE, &
- scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE obj_add23
+ END SUBROUTINE obj_Add23
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add24(obj, dofobj, nodenum, VALUE, &
- scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo
INTEGER(I4B), INTENT(IN) :: timecompo(:)
- END SUBROUTINE obj_add24
+ END SUBROUTINE obj_Add24
END INTERFACE Add
!----------------------------------------------------------------------------
-! set@setMethod
+! Add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Add1]]
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add25(obj, dofobj, nodenum, VALUE, &
- scale, ivar, spacecompo, timecompo)
+ 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
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: spacecompo(:)
INTEGER(I4B), INTENT(IN) :: timecompo
- END SUBROUTINE obj_add25
+ END SUBROUTINE obj_Add25
END INTERFACE Add
!----------------------------------------------------------------------------
-! add@addMethods
+! add
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -529,11 +553,165 @@ END SUBROUTINE obj_add25
! summary: obj1=obj2
INTERFACE Add
- MODULE PURE SUBROUTINE obj_add26(obj, VALUE, scale)
+ MODULE SUBROUTINE obj_Add26(obj, VALUE, scale)
CLASS(RealVector_), INTENT(INOUT) :: obj
CLASS(RealVector_), INTENT(IN) :: VALUE
REAL(DFP), INTENT(IN) :: scale
- END SUBROUTINE obj_add26
+ END SUBROUTINE obj_Add26
+END INTERFACE Add
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-29
+! summary: obj = obj + scale*VALUE
+!
+!# Introduction
+!
+! Value contains the nodal values of all dofs
+! Number of cols in values should be at least equal to the total dof in obj
+! Number of rows in values should be at least equal to the total nodes in obj
+
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add27(obj, dofobj, VALUE, scale)
+ CLASS(RealVector_), INTENT(INOUT) :: obj
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ !! number of cols should be equal to the total dof in obj
+ !! number of rows should be equal to the total nodes in obj
+ REAL(DFP), INTENT(IN) :: scale
+ END SUBROUTINE obj_Add27
+END INTERFACE Add
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-29
+! summary: obj = obj + scale*VALUE
+
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add28(obj, dofobj, VALUE, scale, idof)
+ CLASS(RealVector_), INTENT(INOUT) :: obj
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! number of cols should be equal to the total dof in obj
+ !! number of rows should be equal to the total nodes in obj
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale
+ INTEGER(I4B), INTENT(IN) :: idof
+ !! global degree of freedom in dofobj
+ END SUBROUTINE obj_Add28
+END INTERFACE Add
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-29
+! summary: obj = obj + scale*VALUE
+
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add29(obj1, dofobj1, idof1, obj2, dofobj2, idof2, &
+ scale)
+ TYPE(RealVector_), INTENT(INOUT) :: obj1
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj1
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: idof1
+ !! global degree of freedom in dof1
+ TYPE(RealVector_), INTENT(IN) :: obj2
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj2
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: idof2
+ !! global degree of freedom in dof2
+ REAL(DFP), INTENT(IN) :: scale
+ !! Scale
+ END SUBROUTINE obj_Add29
+END INTERFACE Add
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-30
+! summary: Add range of values to a scalar
+
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add30(obj, dofobj, istart, iend, stride, VALUE, &
+ idof, scale)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! Scalar value
+ INTEGER(I4B), INTENT(IN) :: idof
+ !! global degree of freedom number
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale
+ END SUBROUTINE obj_Add30
+END INTERFACE Add
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-30
+! summary: Add range of values to a vector
+
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add31(obj, dofobj, istart, iend, stride, VALUE, &
+ idof, scale)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ !! ob(istart:iend:stride)=VALUE
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! vector value
+ INTEGER(I4B), INTENT(IN) :: idof
+ !! global degree of freedom number
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale
+ END SUBROUTINE obj_Add31
+END INTERFACE Add
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-30
+! summary: Add range of values to a vector
+
+INTERFACE Add
+ MODULE SUBROUTINE obj_Add32(obj, istart, iend, stride, VALUE, &
+ istart_value, iend_value, stride_value, scale)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ !! ob(istart:iend:stride)=VALUE
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! vector value
+ INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: scale
+ !! scale
+ END SUBROUTINE obj_Add32
END INTERFACE Add
END MODULE RealVector_AddMethods
diff --git a/src/modules/RealVector/src/RealVector_GetMethods.F90 b/src/modules/RealVector/src/RealVector_GetMethods.F90
index 111d00118..fed8f2c22 100644
--- a/src/modules/RealVector/src/RealVector_GetMethods.F90
+++ b/src/modules/RealVector/src/RealVector_GetMethods.F90
@@ -29,7 +29,7 @@ MODULE RealVector_GetMethods
PUBLIC :: GetPointer
!----------------------------------------------------------------------------
-! GetPointer@getMethod
+! GetPointer@GetMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -43,13 +43,13 @@ MODULE RealVector_GetMethods
INTERFACE GetPointer
MODULE FUNCTION obj_GetPointer1(obj) RESULT(val)
- CLASS(RealVector_), INTENT(IN), TARGET :: obj
+ TYPE(RealVector_), INTENT(IN), TARGET :: obj
REAL(DFP), POINTER :: val(:)
END FUNCTION obj_GetPointer1
END INTERFACE GetPointer
!----------------------------------------------------------------------------
-! GetPointer@getMethod
+! GetPointer@GetMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -62,7 +62,7 @@ END FUNCTION obj_GetPointer1
INTERFACE GetPointer
MODULE FUNCTION obj_GetPointer2(obj, dofobj, idof) RESULT(val)
- CLASS(RealVector_), INTENT(IN), TARGET :: obj
+ TYPE(RealVector_), INTENT(IN), TARGET :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: idof
REAL(DFP), POINTER :: val(:)
@@ -70,7 +70,7 @@ END FUNCTION obj_GetPointer2
END INTERFACE GetPointer
!----------------------------------------------------------------------------
-! GetIndex@getMethod
+! GetIndex@GetMethod
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -84,7 +84,7 @@ END FUNCTION obj_GetPointer2
INTERFACE GetIndex
MODULE PURE FUNCTION obj_GetIndex1(obj, VALUE, tol) RESULT(Ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: obj
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), OPTIONAL, INTENT(IN) :: tol
INTEGER(I4B) :: Ans
@@ -106,7 +106,7 @@ END FUNCTION obj_GetIndex1
INTERFACE GetIndex
MODULE PURE FUNCTION obj_GetIndex2(obj, VALUE, tol) RESULT(Ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: obj
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), OPTIONAL, INTENT(IN) :: tol
INTEGER(I4B), ALLOCATABLE :: Ans(:)
@@ -123,7 +123,7 @@ END FUNCTION obj_GetIndex2
INTERFACE IsPresent
MODULE PURE FUNCTION obj_IsPresent1(obj, VALUE, tol) RESULT(Ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: obj
REAL(DFP), INTENT(IN) :: VALUE
REAL(DFP), OPTIONAL, INTENT(IN) :: tol
LOGICAL(LGT) :: Ans
@@ -140,7 +140,7 @@ END FUNCTION obj_IsPresent1
INTERFACE IsPresent
MODULE PURE FUNCTION obj_IsPresent2(obj, VALUE, tol) RESULT(Ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: obj
REAL(DFP), INTENT(IN) :: VALUE(:)
REAL(DFP), OPTIONAL, INTENT(IN) :: tol
LOGICAL(LGT), ALLOCATABLE :: Ans(:)
@@ -156,9 +156,9 @@ END FUNCTION obj_IsPresent2
! summary: This function returns a vector of Integer from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get1(obj, DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
- INTEGER(I4B), INTENT(IN) :: DataType
+ MODULE PURE FUNCTION obj_Get1(obj, dataType) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ INTEGER(I4B), INTENT(IN) :: dataType
INTEGER(I4B), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get1
END INTERFACE Get
@@ -172,10 +172,10 @@ END FUNCTION obj_Get1
! summary: This function returns a vector of integer from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get2(obj, nodenum, DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get2(obj, nodenum, dataType) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- INTEGER(I4B), INTENT(IN) :: DataType
+ INTEGER(I4B), INTENT(IN) :: dataType
INTEGER(I4B), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get2
END INTERFACE Get
@@ -189,11 +189,11 @@ END FUNCTION obj_Get2
! summary: This function returns a vector of integer from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get3(obj, istart, iend, stride, &
- & DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get3(obj, istart, iend, stride, dataType) &
+ RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- INTEGER(I4B), INTENT(IN) :: DataType
+ INTEGER(I4B), INTENT(IN) :: dataType
INTEGER(I4B), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get3
END INTERFACE Get
@@ -207,14 +207,15 @@ END FUNCTION obj_Get3
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get4a(obj, DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
- REAL(REAL32), INTENT(IN) :: DataType
+ MODULE PURE FUNCTION obj_Get4a(obj, dataType) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ REAL(REAL32), INTENT(IN) :: dataType
REAL(REAL32), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get4a
- MODULE PURE FUNCTION obj_Get4b(obj, DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
- REAL(REAL64), INTENT(IN) :: DataType
+
+ MODULE PURE FUNCTION obj_Get4b(obj, dataType) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ REAL(REAL64), INTENT(IN) :: dataType
REAL(REAL64), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get4b
END INTERFACE Get
@@ -228,16 +229,16 @@ END FUNCTION obj_Get4b
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get5a(obj, nodenum, DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get5a(obj, nodenum, dataType) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- REAL(REAL32), INTENT(IN) :: DataType
+ REAL(REAL32), INTENT(IN) :: dataType
REAL(REAL32), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get5a
- MODULE PURE FUNCTION obj_Get5b(obj, nodenum, DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get5b(obj, nodenum, dataType) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- REAL(REAL64), INTENT(IN) :: DataType
+ REAL(REAL64), INTENT(IN) :: dataType
REAL(REAL64), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get5b
END INTERFACE Get
@@ -251,11 +252,11 @@ END FUNCTION obj_Get5b
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get6(obj, istart, iend, stride, &
- & DataType) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get6(obj, istart, iend, stride, dataType) &
+ RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- REAL(DFP), INTENT(IN) :: DataType
+ REAL(DFP), INTENT(IN) :: dataType
REAL(DFP), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get6
END INTERFACE Get
@@ -269,9 +270,9 @@ END FUNCTION obj_Get6
! summary: This function returns the vector of integer from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get7(obj, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
- INTEGER(I4B), INTENT(IN) :: DataType
+ MODULE PURE FUNCTION obj_Get7(obj, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
+ INTEGER(I4B), INTENT(IN) :: dataType
INTEGER(I4B), ALLOCATABLE :: val(:)
END FUNCTION obj_Get7
END INTERFACE Get
@@ -285,10 +286,10 @@ END FUNCTION obj_Get7
! summary: This function returns a vector of integer from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get8(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ MODULE PURE FUNCTION obj_Get8(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- INTEGER(I4B), INTENT(IN) :: DataType
+ INTEGER(I4B), INTENT(IN) :: dataType
INTEGER(I4B), ALLOCATABLE :: val(:)
END FUNCTION obj_Get8
END INTERFACE Get
@@ -302,13 +303,13 @@ END FUNCTION obj_Get8
! summary: This function returns an integer vector from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get9(obj, istart, iend, &
- & stride, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ MODULE PURE FUNCTION obj_Get9(obj, istart, iend, stride, dataType) &
+ RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: istart
INTEGER(I4B), INTENT(IN) :: iend
INTEGER(I4B), INTENT(IN) :: stride
- INTEGER(I4B), INTENT(IN) :: DataType
+ INTEGER(I4B), INTENT(IN) :: dataType
INTEGER(I4B), ALLOCATABLE :: val(:)
END FUNCTION obj_Get9
END INTERFACE Get
@@ -322,14 +323,15 @@ END FUNCTION obj_Get9
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get10a(obj, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
- REAL(REAL32), INTENT(IN) :: DataType
+ MODULE PURE FUNCTION obj_Get10a(obj, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
+ REAL(REAL32), INTENT(IN) :: dataType
REAL(REAL32), ALLOCATABLE :: val(:)
END FUNCTION obj_Get10a
- MODULE PURE FUNCTION obj_Get10b(obj, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
- REAL(REAL64), INTENT(IN) :: DataType
+
+ MODULE PURE FUNCTION obj_Get10b(obj, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
+ REAL(REAL64), INTENT(IN) :: dataType
REAL(REAL64), ALLOCATABLE :: val(:)
END FUNCTION obj_Get10b
END INTERFACE Get
@@ -343,15 +345,16 @@ END FUNCTION obj_Get10b
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get11a(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
- REAL(REAL32), INTENT(IN) :: DataType
+ MODULE PURE FUNCTION obj_Get11a(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
+ REAL(REAL32), INTENT(IN) :: dataType
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(REAL32), ALLOCATABLE :: val(:)
END FUNCTION obj_Get11a
- MODULE PURE FUNCTION obj_Get11b(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
- REAL(REAL64), INTENT(IN) :: DataType
+
+ MODULE PURE FUNCTION obj_Get11b(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
+ REAL(REAL64), INTENT(IN) :: dataType
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(REAL64), ALLOCATABLE :: val(:)
END FUNCTION obj_Get11b
@@ -366,18 +369,19 @@ END FUNCTION obj_Get11b
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get12a(obj, istart, iend, stride, &
- & DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ MODULE PURE FUNCTION obj_Get12a(obj, istart, iend, stride, dataType) &
+ RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- REAL(REAL32), INTENT(IN) :: DataType
+ REAL(REAL32), INTENT(IN) :: dataType
REAL(REAL32), ALLOCATABLE :: val(:)
END FUNCTION obj_Get12a
+
MODULE PURE FUNCTION obj_Get12b(obj, istart, iend, stride, &
- & DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ & dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- REAL(REAL64), INTENT(IN) :: DataType
+ REAL(REAL64), INTENT(IN) :: dataType
REAL(REAL64), ALLOCATABLE :: val(:)
END FUNCTION obj_Get12b
END INTERFACE Get
@@ -395,9 +399,9 @@ END FUNCTION obj_Get12b
! combining different entries of a vector of [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get13(obj, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
- TYPE(RealVector_), INTENT(IN) :: DataType
+ MODULE PURE FUNCTION obj_Get13(obj, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
+ TYPE(RealVector_), INTENT(IN) :: dataType
TYPE(RealVector_) :: val
END FUNCTION obj_Get13
END INTERFACE Get
@@ -415,10 +419,10 @@ END FUNCTION obj_Get13
! [[RealVector_]].
INTERFACE Get
- MODULE PURE FUNCTION obj_Get14(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ MODULE PURE FUNCTION obj_Get14(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- TYPE(RealVector_), INTENT(IN) :: DataType
+ TYPE(RealVector_), INTENT(IN) :: dataType
TYPE(RealVector_) :: val
END FUNCTION obj_Get14
END INTERFACE Get
@@ -437,10 +441,10 @@ END FUNCTION obj_Get14
INTERFACE Get
MODULE PURE FUNCTION obj_Get15(obj, istart, iend, stride, &
- & DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- TYPE(RealVector_), INTENT(IN) :: DataType
+ TYPE(RealVector_), INTENT(IN) :: dataType
TYPE(RealVector_) :: val
END FUNCTION obj_Get15
END INTERFACE Get
@@ -459,10 +463,10 @@ END FUNCTION obj_Get15
! from `obj`
INTERFACE Get
- MODULE PURE FUNCTION obj_Get16(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get16(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
- TYPE(RealVector_), INTENT(IN) :: DataType
+ TYPE(RealVector_), INTENT(IN) :: dataType
TYPE(RealVector_) :: val
END FUNCTION obj_Get16
END INTERFACE Get
@@ -481,10 +485,10 @@ END FUNCTION obj_Get16
INTERFACE Get
MODULE PURE FUNCTION obj_Get17(obj, istart, iend, stride, &
- & DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj
+ dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- TYPE(RealVector_), INTENT(IN) :: DataType
+ TYPE(RealVector_), INTENT(IN) :: dataType
TYPE(RealVector_) :: val
END FUNCTION obj_Get17
END INTERFACE Get
@@ -494,16 +498,17 @@ END FUNCTION obj_Get17
!----------------------------------------------------------------------------
INTERFACE Get
- MODULE PURE FUNCTION obj_Get18a(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get18a(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
- REAL(REAL32), INTENT(IN) :: DataType
+ REAL(REAL32), INTENT(IN) :: dataType
REAL(REAL32) :: val
END FUNCTION obj_Get18a
- MODULE PURE FUNCTION obj_Get18b(obj, nodenum, DataType) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj
+
+ MODULE PURE FUNCTION obj_Get18b(obj, nodenum, dataType) RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
- REAL(REAL64), INTENT(IN) :: DataType
+ REAL(REAL64), INTENT(IN) :: dataType
REAL(REAL64) :: val
END FUNCTION obj_Get18b
END INTERFACE Get
@@ -518,7 +523,7 @@ END FUNCTION obj_Get18b
INTERFACE Get
MODULE PURE FUNCTION obj_Get19(obj) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: obj
REAL(DFP), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get19
END INTERFACE Get
@@ -533,7 +538,7 @@ END FUNCTION obj_Get19
INTERFACE Get
MODULE PURE FUNCTION obj_Get20(obj, nodenum) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get20
@@ -549,8 +554,8 @@ END FUNCTION obj_Get20
INTERFACE Get
MODULE PURE FUNCTION obj_Get21(obj, istart, iend, stride) &
- & RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
REAL(DFP), ALLOCATABLE :: ans(:)
END FUNCTION obj_Get21
@@ -566,7 +571,7 @@ END FUNCTION obj_Get21
INTERFACE Get
MODULE PURE FUNCTION obj_Get22(obj) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
REAL(DFP), ALLOCATABLE :: val(:)
END FUNCTION obj_Get22
END INTERFACE Get
@@ -581,7 +586,7 @@ END FUNCTION obj_Get22
INTERFACE Get
MODULE PURE FUNCTION obj_Get23(obj, nodenum) RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: nodenum(:)
REAL(DFP), ALLOCATABLE :: val(:)
END FUNCTION obj_Get23
@@ -597,8 +602,8 @@ END FUNCTION obj_Get23
INTERFACE Get
MODULE PURE FUNCTION obj_Get24(obj, istart, iend, stride) &
- & RESULT(val)
- CLASS(RealVector_), INTENT(IN) :: obj(:)
+ RESULT(val)
+ TYPE(RealVector_), INTENT(IN) :: obj(:)
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
REAL(DFP), ALLOCATABLE :: val(:)
END FUNCTION obj_Get24
@@ -613,9 +618,9 @@ END FUNCTION obj_Get24
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get25(obj, dofobj, nodenum, &
- & ivar, idof) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get25(obj, dofobj, nodenum, ivar, idof) &
+ RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum
INTEGER(I4B), INTENT(IN) :: ivar
@@ -633,9 +638,9 @@ END FUNCTION obj_Get25
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get26(obj, dofobj, nodenum, &
- & ivar, idof) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get26(obj, dofobj, nodenum, ivar, idof) &
+ RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
INTEGER(I4B), INTENT(IN) :: ivar
@@ -653,9 +658,8 @@ END FUNCTION obj_Get26
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE Get
- MODULE PURE FUNCTION obj_Get27(obj, dofobj, nodenum, &
- & ivar) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE PURE FUNCTION obj_Get27(obj, dofobj, nodenum, ivar) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
INTEGER(I4B), INTENT(IN) :: ivar
@@ -673,8 +677,8 @@ END FUNCTION obj_Get27
INTERFACE Get
MODULE PURE FUNCTION obj_Get28(obj, dofobj, nodenum, &
- & ivar, spacecompo, timecompo) RESULT(ans)
- CLASS(RealVector_), INTENT(IN) :: obj
+ ivar, spacecompo, timecompo) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: nodenum(:)
INTEGER(I4B), INTENT(IN) :: ivar
@@ -684,4 +688,21 @@ MODULE PURE FUNCTION obj_Get28(obj, dofobj, nodenum, &
END FUNCTION obj_Get28
END INTERFACE Get
+!----------------------------------------------------------------------------
+! Get@GetMethod
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Feb 2021
+! summary: This function returns a vector of real from [[RealVector_]]
+
+INTERFACE Get
+ MODULE PURE FUNCTION obj_Get29(obj, dofobj, idof) RESULT(ans)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ INTEGER(I4B), INTENT(IN) :: idof
+ REAL(DFP), ALLOCATABLE :: ans(:)
+ END FUNCTION obj_Get29
+END INTERFACE Get
+
END MODULE RealVector_GetMethods
diff --git a/src/modules/RealVector/src/RealVector_GetValueMethods.F90 b/src/modules/RealVector/src/RealVector_GetValueMethods.F90
index 6cc45ba23..cff868762 100644
--- a/src/modules/RealVector/src/RealVector_GetValueMethods.F90
+++ b/src/modules/RealVector/src/RealVector_GetValueMethods.F90
@@ -25,6 +25,13 @@ MODULE RealVector_GetValueMethods
PUBLIC :: GetValue
PUBLIC :: GetValue_
+INTERFACE GetValue_
+MODULE PROCEDURE obj_GetValue1, obj_GetValue2, obj_GetValue3, obj_GetValue4, &
+ obj_GetValue5, obj_GetValue6, obj_GetValue7, obj_GetValue8, &
+ obj_GetValue9, obj_GetValue10, obj_GetValue11, obj_GetValue15, &
+ obj_GetValue24
+END INTERFACE GetValue_
+
!----------------------------------------------------------------------------
! GetValue
!----------------------------------------------------------------------------
@@ -39,12 +46,16 @@ MODULE RealVector_GetValueMethods
! RealVector.
!
! Both obj and value should be allocated.
+!
+!@note
+! We call set method
+!@endnote
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue1(obj, VALUE, istart, iend, stride)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue1(obj, VALUE, istart, iend, stride)
+ TYPE(RealVector_), INTENT(IN) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
END SUBROUTINE obj_GetValue1
END INTERFACE GetValue
@@ -62,12 +73,16 @@ END SUBROUTINE obj_GetValue1
! RealVector.
!
! Both obj and value should be allocated.
+!
+!@note
+! We call set method
+!@endnote
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue2(obj, dofobj, VALUE, idof)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue2(obj, dofobj, VALUE, idof)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
INTEGER(I4B), INTENT(IN) :: idof
END SUBROUTINE obj_GetValue2
END INTERFACE GetValue
@@ -88,10 +103,10 @@ END SUBROUTINE obj_GetValue2
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue3(obj, dofobj, VALUE, ivar, idof)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue3(obj, dofobj, VALUE, ivar, idof)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
INTEGER(I4B), INTENT(IN) :: ivar
INTEGER(I4B), INTENT(IN) :: idof
END SUBROUTINE obj_GetValue3
@@ -113,14 +128,14 @@ END SUBROUTINE obj_GetValue3
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue4(obj, dofobj, VALUE, ivar, &
- spacecompo, timecompo)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue4(obj, dofobj, VALUE, ivar, &
+ spaceCompo, timeCompo)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
INTEGER(I4B), INTENT(IN) :: ivar
- INTEGER(I4B), INTENT(IN) :: spacecompo
- INTEGER(I4B), INTENT(IN) :: timecompo
+ INTEGER(I4B), INTENT(IN) :: spaceCompo
+ INTEGER(I4B), INTENT(IN) :: timeCompo
END SUBROUTINE obj_GetValue4
END INTERFACE GetValue
@@ -140,15 +155,15 @@ END SUBROUTINE obj_GetValue4
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue5(obj, dofobj, idofobj, &
- VALUE, dofvalue, idofvalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue5(obj, dofobj, idofobj, &
+ VALUE, dofvalue, idofvalue)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! Real vector whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! DOF for obj
INTEGER(I4B), INTENT(IN) :: idofobj
!! idof for obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
!! real vector to be returned
TYPE(DOF_), INTENT(IN) :: dofvalue
!! dof for value
@@ -177,15 +192,15 @@ END SUBROUTINE obj_GetValue5
!@endnote
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue6(obj, dofobj, idofobj, &
- VALUE, dofvalue, idofvalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue6(obj, dofobj, idofobj, &
+ VALUE, dofvalue, idofvalue)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! Real vector whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! DOF for obj
INTEGER(I4B), INTENT(IN) :: idofobj(:)
!! idof for obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
!! values to be returned
TYPE(DOF_), INTENT(IN) :: dofvalue
!! dof for value
@@ -210,19 +225,22 @@ END SUBROUTINE obj_GetValue6
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue7(obj, dofobj, ivarobj, idofobj, &
- VALUE, dofvalue, ivarvalue, idofvalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue7(obj, dofobj, ivarobj, idofobj, &
+ VALUE, dofvalue, ivarvalue, idofvalue)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
- !! DOF for obj
+ !! degree of freedom object for obj
INTEGER(I4B), INTENT(IN) :: ivarobj
!! physical variable for obj
INTEGER(I4B), INTENT(IN) :: idofobj
- !! idof for obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ !! local degree of freedom of physical variable for obj
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
TYPE(DOF_), INTENT(IN) :: dofvalue
+ !! degree of freedom object for value
INTEGER(I4B), INTENT(IN) :: ivarvalue
+ !! physical variable for value
INTEGER(I4B), INTENT(IN) :: idofvalue
+ !! local degree of freedom of physical variable for value
END SUBROUTINE obj_GetValue7
END INTERFACE GetValue
@@ -240,18 +258,30 @@ END SUBROUTINE obj_GetValue7
! RealVector.
!
! Both obj and value should be allocated.
+!
+!@note
+! The size of idofobj and idofvalue should be equal.
+!@endnote
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue8(obj, dofobj, ivarobj, idofobj, &
- VALUE, dofvalue, ivarvalue, idofvalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue8(obj, dofobj, ivarobj, idofobj, &
+ VALUE, dofvalue, ivarvalue, idofvalue)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! Real vector whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object for obj
INTEGER(I4B), INTENT(IN) :: ivarobj
+ !! physical variable for obj
INTEGER(I4B), INTENT(IN) :: idofobj(:)
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ !! local degree of freedom of physical variable for obj
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
+ !! values to be returned
TYPE(DOF_), INTENT(IN) :: dofvalue
+ !! degree of freedom object for value
INTEGER(I4B), INTENT(IN) :: ivarvalue
+ !! physical variable for value
INTEGER(I4B), INTENT(IN) :: idofvalue(:)
+ !! local degree of freedom of physical variable for value
END SUBROUTINE obj_GetValue8
END INTERFACE GetValue
@@ -271,27 +301,27 @@ END SUBROUTINE obj_GetValue8
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue9(obj, dofobj, ivarobj, &
- spacecompoobj, timecompoobj, VALUE, dofvalue, ivarvalue, &
- spacecompovalue, timecompovalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue9(obj, dofobj, ivarobj, &
+ spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, &
+ spaceCompoValue, timeCompoValue)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
INTEGER(I4B), INTENT(IN) :: ivarobj
!! physical variable for obj
- INTEGER(I4B), INTENT(IN) :: spacecompoobj
+ INTEGER(I4B), INTENT(IN) :: spaceCompoObj
!! space component for obj
- INTEGER(I4B), INTENT(IN) :: timecompoobj
+ INTEGER(I4B), INTENT(IN) :: timeCompoObj
!! time component for obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
!! values to be returned
TYPE(DOF_), INTENT(IN) :: dofvalue
!! dof for value
INTEGER(I4B), INTENT(IN) :: ivarvalue
!! physical variable for value
- INTEGER(I4B), INTENT(IN) :: spacecompovalue
+ INTEGER(I4B), INTENT(IN) :: spaceCompoValue
!! space component for value
- INTEGER(I4B), INTENT(IN) :: timecompovalue
+ INTEGER(I4B), INTENT(IN) :: timeCompoValue
!! time component for value
END SUBROUTINE obj_GetValue9
END INTERFACE GetValue
@@ -312,27 +342,27 @@ END SUBROUTINE obj_GetValue9
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue10(obj, dofobj, ivarobj, &
- spacecompoobj, timecompoobj, VALUE, dofvalue, ivarvalue, &
- spacecompovalue, timecompovalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue10(obj, dofobj, ivarobj, &
+ spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, &
+ spaceCompoValue, timeCompoValue)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
INTEGER(I4B), INTENT(IN) :: ivarobj
!! physical variable for obj
- INTEGER(I4B), INTENT(IN) :: spacecompoobj
+ INTEGER(I4B), INTENT(IN) :: spaceCompoObj
!! space component for obj
- INTEGER(I4B), INTENT(IN) :: timecompoobj(:)
+ INTEGER(I4B), INTENT(IN) :: timeCompoObj(:)
!! time component for obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
!! values to be returned
TYPE(DOF_), INTENT(IN) :: dofvalue
!! dof value
INTEGER(I4B), INTENT(IN) :: ivarvalue
!! physical variable for value
- INTEGER(I4B), INTENT(IN) :: spacecompovalue
+ INTEGER(I4B), INTENT(IN) :: spaceCompoValue
!! space compoenent for value
- INTEGER(I4B), INTENT(IN) :: timecompovalue(:)
+ INTEGER(I4B), INTENT(IN) :: timeCompoValue(:)
!! time component for value
END SUBROUTINE obj_GetValue10
END INTERFACE GetValue
@@ -353,27 +383,27 @@ END SUBROUTINE obj_GetValue10
! Both obj and value should be allocated.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue11(obj, dofobj, ivarobj, &
- spacecompoobj, timecompoobj, VALUE, dofvalue, ivarvalue, &
- spacecompovalue, timecompovalue)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue11(obj, dofobj, ivarobj, &
+ spaceCompoObj, timeCompoObj, VALUE, dofvalue, ivarvalue, &
+ spaceCompoValue, timeCompoValue)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
INTEGER(I4B), INTENT(IN) :: ivarobj
!! physical variable for obj
- INTEGER(I4B), INTENT(IN) :: spacecompoobj(:)
+ INTEGER(I4B), INTENT(IN) :: spaceCompoObj(:)
!! space component for obj
- INTEGER(I4B), INTENT(IN) :: timecompoobj
+ INTEGER(I4B), INTENT(IN) :: timeCompoObj
!! time component for obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
!! values to be returned
TYPE(DOF_), INTENT(IN) :: dofvalue
!! dof value
INTEGER(I4B), INTENT(IN) :: ivarvalue
!! physical variable for value
- INTEGER(I4B), INTENT(IN) :: spacecompovalue(:)
+ INTEGER(I4B), INTENT(IN) :: spaceCompoValue(:)
!! psace component for value
- INTEGER(I4B), INTENT(IN) :: timecompovalue
+ INTEGER(I4B), INTENT(IN) :: timeCompoValue
!! time component for value
END SUBROUTINE obj_GetValue11
END INTERFACE GetValue
@@ -395,14 +425,14 @@ END SUBROUTINE obj_GetValue11
! format of returned vector.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue12(obj, dofobj, idof, VALUE, &
- storageFMT, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
- !! obj
+ MODULE SUBROUTINE obj_GetValue12(obj, dofobj, idof, VALUE, &
+ storageFMT, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! obj to extract values
TYPE(DOF_), INTENT(IN) :: dofobj
- !! dof for obj
+ !! degree of freedom for obj
INTEGER(I4B), INTENT(IN) :: idof(:)
- !! idof for obj
+ !! global degree of freedom for obj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
!! values to be returned
INTEGER(I4B), INTENT(IN) :: storageFMT
@@ -428,9 +458,9 @@ END SUBROUTINE obj_GetValue12
! format of returned vector.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue13(obj, dofobj, idof, VALUE, &
- storageFMT)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue13(obj, dofobj, idof, VALUE, &
+ storageFMT)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj to extract values
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -459,9 +489,9 @@ END SUBROUTINE obj_GetValue13
! format of returned vector.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue14(obj, dofobj, idof, VALUE, &
- force3D)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue14(obj, dofobj, idof, VALUE, &
+ force3D)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj to extract values
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -483,9 +513,9 @@ END SUBROUTINE obj_GetValue14
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue15(obj, dofobj, ivar, idof, &
- VALUE, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue15(obj, dofobj, ivar, idof, &
+ VALUE, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -509,9 +539,9 @@ END SUBROUTINE obj_GetValue15
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue16(obj, dofobj, ivar, idof, &
- VALUE, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue16(obj, dofobj, ivar, idof, &
+ VALUE, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -535,8 +565,8 @@ END SUBROUTINE obj_GetValue16
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue17(obj, dofobj, ivar, VALUE, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue17(obj, dofobj, ivar, VALUE, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -558,13 +588,13 @@ END SUBROUTINE obj_GetValue17
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue18(obj, dofobj, ivar, spacecompo, &
- timecompo, VALUE, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue18(obj, dofobj, ivar, spaceCompo, &
+ timeCompo, VALUE, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: ivar
- INTEGER(I4B), INTENT(IN) :: spacecompo
- INTEGER(I4B), INTENT(IN) :: timecompo
+ INTEGER(I4B), INTENT(IN) :: spaceCompo
+ INTEGER(I4B), INTENT(IN) :: timeCompo
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(IN) :: nodenum(:)
END SUBROUTINE obj_GetValue18
@@ -579,8 +609,8 @@ END SUBROUTINE obj_GetValue18
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue19(obj, dofobj, VALUE, idof)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue19(obj, dofobj, VALUE, idof)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(IN) :: idof
@@ -596,8 +626,8 @@ END SUBROUTINE obj_GetValue19
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue20(obj, dofobj, VALUE, ivar, idof)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue20(obj, dofobj, VALUE, ivar, idof)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(IN) :: ivar
@@ -614,14 +644,14 @@ END SUBROUTINE obj_GetValue20
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue21(obj, dofobj, VALUE, ivar, &
- spacecompo, timecompo)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue21(obj, dofobj, VALUE, ivar, &
+ spaceCompo, timeCompo)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(IN) :: ivar
- INTEGER(I4B), INTENT(IN) :: spacecompo
- INTEGER(I4B), INTENT(IN) :: timecompo
+ INTEGER(I4B), INTENT(IN) :: spaceCompo
+ INTEGER(I4B), INTENT(IN) :: timeCompo
END SUBROUTINE obj_GetValue21
END INTERFACE GetValue
@@ -641,8 +671,8 @@ END SUBROUTINE obj_GetValue21
! format of returned vector.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue22(obj, dofobj, idof, VALUE, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue22(obj, dofobj, idof, VALUE, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: idof(:)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
@@ -666,8 +696,8 @@ END SUBROUTINE obj_GetValue22
! format of returned vector.
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue23(obj, dofobj, idof, VALUE)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue23(obj, dofobj, idof, VALUE)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: idof(:)
REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: VALUE(:)
@@ -683,9 +713,9 @@ END SUBROUTINE obj_GetValue23
! summary: copy a realvector into another realvector
INTERFACE GetValue
- MODULE PURE SUBROUTINE obj_GetValue24(obj, VALUE)
- CLASS(RealVector_), INTENT(IN) :: obj
- CLASS(RealVector_), INTENT(INOUT) :: VALUE
+ MODULE SUBROUTINE obj_GetValue24(obj, VALUE)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ TYPE(RealVector_), INTENT(INOUT) :: VALUE
END SUBROUTINE obj_GetValue24
END INTERFACE GetValue
@@ -703,9 +733,9 @@ END SUBROUTINE obj_GetValue24
! extra memory for value.
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_12(obj, dofobj, idof, VALUE, &
- tsize, storageFMT, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_12(obj, dofobj, idof, VALUE, &
+ tsize, storageFMT, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -736,9 +766,9 @@ END SUBROUTINE obj_GetValue_12
! extra memory for value.
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_13(obj, dofobj, idof, VALUE, &
- tsize, storageFMT)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_13(obj, dofobj, idof, VALUE, &
+ tsize, storageFMT)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj to extract values
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -767,9 +797,9 @@ END SUBROUTINE obj_GetValue_13
! extra memory for value.
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_14(obj, dofobj, idof, VALUE, &
- nrow, ncol, force3D)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_14(obj, dofobj, idof, VALUE, &
+ nrow, ncol, force3D)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj to extract values
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -793,9 +823,9 @@ END SUBROUTINE obj_GetValue_14
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_16(obj, dofobj, ivar, idof, &
- VALUE, tsize, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_16(obj, dofobj, ivar, idof, &
+ VALUE, tsize, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -828,9 +858,9 @@ END SUBROUTINE obj_GetValue_16
!@endnote
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_17(obj, dofobj, ivar, VALUE, &
- tsize, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_17(obj, dofobj, ivar, VALUE, &
+ tsize, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj whose value is to be extracted
TYPE(DOF_), INTENT(IN) :: dofobj
!! dof for obj
@@ -854,16 +884,16 @@ END SUBROUTINE obj_GetValue_17
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_18(obj, dofobj, ivar, spacecompo, &
- timecompo, VALUE, tsize, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_18(obj, dofobj, ivar, spaceCompo, &
+ timeCompo, VALUE, tsize, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! degree of freedom for obj
INTEGER(I4B), INTENT(IN) :: ivar
!! physical variable for obj
- INTEGER(I4B), INTENT(IN) :: spacecompo
+ INTEGER(I4B), INTENT(IN) :: spaceCompo
!! space component for obj
- INTEGER(I4B), INTENT(IN) :: timecompo
+ INTEGER(I4B), INTENT(IN) :: timeCompo
!! time component for obj
REAL(DFP), INTENT(INOUT) :: VALUE(:)
!! values to be returned
@@ -883,8 +913,8 @@ END SUBROUTINE obj_GetValue_18
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_19(obj, dofobj, VALUE, tsize, idof)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_19(obj, dofobj, VALUE, tsize, idof)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
REAL(DFP), INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(OUT) :: tsize
@@ -901,9 +931,9 @@ END SUBROUTINE obj_GetValue_19
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_20(obj, dofobj, VALUE, tsize, &
- ivar, idof)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_20(obj, dofobj, VALUE, tsize, &
+ ivar, idof)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
REAL(DFP), INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(OUT) :: tsize
@@ -921,15 +951,15 @@ END SUBROUTINE obj_GetValue_20
! summary: This function returns a vector of real from [[RealVector_]]
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_21(obj, dofobj, VALUE, tsize, ivar, &
- spacecompo, timecompo)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_21(obj, dofobj, VALUE, tsize, ivar, &
+ spaceCompo, timeCompo)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
REAL(DFP), INTENT(INOUT) :: VALUE(:)
INTEGER(I4B), INTENT(OUT) :: tsize
INTEGER(I4B), INTENT(IN) :: ivar
- INTEGER(I4B), INTENT(IN) :: spacecompo
- INTEGER(I4B), INTENT(IN) :: timecompo
+ INTEGER(I4B), INTENT(IN) :: spaceCompo
+ INTEGER(I4B), INTENT(IN) :: timeCompo
END SUBROUTINE obj_GetValue_21
END INTERFACE GetValue_
@@ -949,9 +979,9 @@ END SUBROUTINE obj_GetValue_21
! format of returned vector.
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_22(obj, dofobj, idof, VALUE, &
- tsize, nodenum)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_22(obj, dofobj, idof, VALUE, &
+ tsize, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
INTEGER(I4B), INTENT(IN) :: idof(:)
REAL(DFP), INTENT(INOUT) :: VALUE(:)
@@ -976,8 +1006,8 @@ END SUBROUTINE obj_GetValue_22
! format of returned vector.
INTERFACE GetValue_
- MODULE PURE SUBROUTINE obj_GetValue_23(obj, dofobj, idof, VALUE, tsize)
- CLASS(RealVector_), INTENT(IN) :: obj
+ MODULE SUBROUTINE obj_GetValue_23(obj, dofobj, idof, VALUE, tsize)
+ TYPE(RealVector_), INTENT(IN) :: obj
!! obj to extract values
TYPE(DOF_), INTENT(IN) :: dofobj
!! degree of freedom for obj
@@ -990,6 +1020,147 @@ MODULE PURE SUBROUTINE obj_GetValue_23(obj, dofobj, idof, VALUE, tsize)
END SUBROUTINE obj_GetValue_23
END INTERFACE GetValue_
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 26 June 2021
+! summary: Returns the values of degrees of freedom in a single vector
+!
+!# Introduction
+! This subroutine extracts the values from `val` corresponding to
+! degrees of freedom specified by `idof(:)` and return it in `V`
+!
+! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage
+! format of returned vector.
+
+INTERFACE GetValue_
+ MODULE SUBROUTINE obj_GetValue_24(obj, dofobj, idof, VALUE, nrow, ncol, &
+ storageFMT, nodenum)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! obj to extract values
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! dof for obj
+ INTEGER(I4B), INTENT(IN) :: idof(:)
+ !! idof for obj
+ REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
+ !! values to be returned
+ INTEGER(I4B), INTENT(OUT) :: nrow
+ !! number of rows written to value
+ INTEGER(I4B), INTENT(OUT) :: ncol
+ !! number of columns written to value
+ INTEGER(I4B), INTENT(IN) :: storageFMT
+ !! storage format can be DOF_FMT or Nodes_FMT
+ !! if DOF_FMT then nrow size(nodenum) and ncol size(idof)
+ !! if Nodes_FMT then nrow is size(idof) and ncol is size(nodenum)
+ INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! node numbers
+ END SUBROUTINE obj_GetValue_24
+END INTERFACE GetValue_
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 26 June 2021
+! summary: Returns the values of degrees of freedom in a single vector
+!
+!# Introduction
+! This subroutine extracts the values from `val` corresponding to
+! degrees of freedom specified by `idof(:)` and return it in `V`
+!
+! - `StorageFMT` can be 'Nodes_FMT' or `DOF_FMT`. It specify the storage
+! format of returned vector.
+
+INTERFACE GetValue_
+ MODULE SUBROUTINE obj_GetValue_25(obj, dofobj, idof, VALUE, nrow, ncol, &
+ storageFMT)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! obj to extract values
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! dof for obj
+ INTEGER(I4B), INTENT(IN) :: idof(:)
+ !! idof for obj
+ REAL(DFP), INTENT(INOUT) :: VALUE(:, :)
+ !! values to be returned
+ INTEGER(I4B), INTENT(OUT) :: nrow
+ !! number of rows written to value
+ INTEGER(I4B), INTENT(OUT) :: ncol
+ !! number of columns written to value
+ INTEGER(I4B), INTENT(IN) :: storageFMT
+ !! storage format can be DOF_FMT or Nodes_FMT
+ !! if DOF_FMT then nrow size(nodenum) and ncol size(idof)
+ !! if Nodes_FMT then nrow is size(idof) and ncol is size(nodenum)
+ END SUBROUTINE obj_GetValue_25
+END INTERFACE GetValue_
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 26 June 2021
+! summary: Get multiple values
+
+INTERFACE GetValue_
+ MODULE SUBROUTINE obj_GetValue_26(obj, nodenum, VALUE, tsize)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! obj to extract values
+ INTEGER(I4B), INTENT(IN) :: nodenum(:)
+ !! index
+ REAL(DFP), INTENT(INOUT) :: VALUE(:)
+ !! values to be returned
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size written to value
+ END SUBROUTINE obj_GetValue_26
+END INTERFACE GetValue_
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 26 June 2021
+! summary: Get multiple values
+
+INTERFACE GetValue_
+ MODULE SUBROUTINE obj_GetValue_27(obj, istart, iend, stride, VALUE, tsize)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! obj to extract values
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! index
+ REAL(DFP), INTENT(INOUT) :: VALUE(:)
+ !! values to be returned
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size written to value
+ END SUBROUTINE obj_GetValue_27
+END INTERFACE GetValue_
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 26 June 2021
+! summary: Get multiple values
+
+INTERFACE GetValue_
+ MODULE SUBROUTINE obj_GetValue_28(obj, istart, iend, stride, VALUE, &
+ tsize, istart_value, iend_value, stride_value)
+ TYPE(RealVector_), INTENT(IN) :: obj
+ !! obj to extract values
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! index
+ REAL(DFP), INTENT(INOUT) :: VALUE(:)
+ !! values to be returned
+ INTEGER(I4B), INTENT(OUT) :: tsize
+ !! total size written to value
+ INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value
+ END SUBROUTINE obj_GetValue_28
+END INTERFACE GetValue_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/modules/RealVector/src/RealVector_SetMethods.F90 b/src/modules/RealVector/src/RealVector_SetMethods.F90
index 86dd3110e..9510aad40 100644
--- a/src/modules/RealVector/src/RealVector_SetMethods.F90
+++ b/src/modules/RealVector/src/RealVector_SetMethods.F90
@@ -39,10 +39,10 @@ MODULE RealVector_SetMethods
!@endnote
INTERFACE Set
- MODULE SUBROUTINE obj_set1(obj, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
+ MODULE SUBROUTINE obj_Set1(obj, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: VALUE
- END SUBROUTINE obj_set1
+ END SUBROUTINE obj_Set1
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -60,11 +60,11 @@ END SUBROUTINE obj_set1
!@endnote
INTERFACE Set
- MODULE SUBROUTINE obj_set2(obj, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
+ MODULE SUBROUTINE obj_Set2(obj, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
REAL(DFP), INTENT(IN) :: VALUE(:)
!! the length of the vector must be equal to the length of the object
- END SUBROUTINE obj_set2
+ END SUBROUTINE obj_Set2
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -76,13 +76,13 @@ END SUBROUTINE obj_set2
! summary: set selected values (obj(nodenum)=VALUE)
INTERFACE Set
- MODULE SUBROUTINE obj_set3(obj, nodenum, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
+ MODULE SUBROUTINE obj_Set3(obj, nodenum, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: nodenum
!! node number to set the value
REAL(DFP), INTENT(IN) :: VALUE
!! scalar value
- END SUBROUTINE obj_set3
+ END SUBROUTINE obj_Set3
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -91,17 +91,17 @@ END SUBROUTINE obj_set3
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set4(obj, nodenum, VALUE)
+ MODULE PURE SUBROUTINE obj_Set4(obj, nodenum, VALUE)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
INTEGER(I4B), INTENT(IN) :: nodenum(:)
!! node number to set the value
REAL(DFP), INTENT(IN) :: VALUE
!! scalar value
- END SUBROUTINE obj_set4
+ END SUBROUTINE obj_Set4
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -113,14 +113,14 @@ END SUBROUTINE obj_set4
! summary: set selected values
INTERFACE Set
- MODULE SUBROUTINE obj_set5(obj, nodenum, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
+ MODULE SUBROUTINE obj_Set5(obj, nodenum, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
INTEGER(I4B), INTENT(IN) :: nodenum(:)
!! node number to set the value
REAL(DFP), INTENT(IN) :: VALUE(:)
!! vector value, the size of value should be equal to tdof * size(nodenum)
- END SUBROUTINE obj_set5
+ END SUBROUTINE obj_Set5
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -132,13 +132,13 @@ END SUBROUTINE obj_set5
! summary: Set range of values to a scalar
INTERFACE Set
- MODULE SUBROUTINE obj_set6(obj, istart, iend, stride, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
+ MODULE SUBROUTINE obj_Set6(obj, istart, iend, stride, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
!! range of values to set
REAL(DFP), INTENT(IN) :: VALUE
!! Scalar value
- END SUBROUTINE obj_set6
+ END SUBROUTINE obj_Set6
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -150,14 +150,14 @@ END SUBROUTINE obj_set6
! summary: Set range of values to a vector
INTERFACE Set
- MODULE SUBROUTINE obj_set7(obj, istart, iend, stride, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
+ MODULE SUBROUTINE obj_Set7(obj, istart, iend, stride, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
!! ob(istart:iend:stride)=VALUE
INTEGER(I4B), INTENT(IN) :: istart, iend, stride
!! range of values to set
REAL(DFP), INTENT(IN) :: VALUE(:)
!! vector value
- END SUBROUTINE obj_set7
+ END SUBROUTINE obj_Set7
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -166,10 +166,10 @@ END SUBROUTINE obj_set7
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set8(obj, dofobj, nodenum, VALUE, conversion)
+ MODULE PURE SUBROUTINE obj_Set8(obj, dofobj, nodenum, VALUE, conversion)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -180,7 +180,7 @@ MODULE PURE SUBROUTINE obj_set8(obj, dofobj, nodenum, VALUE, conversion)
!! vector value
INTEGER(I4B), INTENT(IN) :: conversion(1)
!! conversion factor, NodesToDOF, DOFToNodes
- END SUBROUTINE obj_set8
+ END SUBROUTINE obj_Set8
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -189,10 +189,10 @@ END SUBROUTINE obj_set8
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set9(obj, dofobj, nodenum, VALUE)
+ MODULE PURE SUBROUTINE obj_Set9(obj, dofobj, nodenum, VALUE)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -201,7 +201,7 @@ MODULE PURE SUBROUTINE obj_set9(obj, dofobj, nodenum, VALUE)
!! node number to set the value
REAL(DFP), INTENT(IN) :: VALUE
!! scalar value
- END SUBROUTINE obj_set9
+ END SUBROUTINE obj_Set9
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -210,10 +210,10 @@ END SUBROUTINE obj_set9
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set10(obj, dofobj, nodenum, VALUE, idof)
+ MODULE PURE SUBROUTINE obj_Set10(obj, dofobj, nodenum, VALUE, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -225,7 +225,7 @@ MODULE PURE SUBROUTINE obj_set10(obj, dofobj, nodenum, VALUE, idof)
!! the size of value should be equal to size(nodenum)
INTEGER(I4B), INTENT(IN) :: idof
!! global degree of freedom number
- END SUBROUTINE obj_set10
+ END SUBROUTINE obj_Set10
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -234,10 +234,10 @@ END SUBROUTINE obj_set10
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set11(obj, dofobj, nodenum, VALUE, idof)
+ MODULE PURE SUBROUTINE obj_Set11(obj, dofobj, nodenum, VALUE, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -248,7 +248,7 @@ MODULE PURE SUBROUTINE obj_set11(obj, dofobj, nodenum, VALUE, idof)
!! scalar value
INTEGER(I4B), INTENT(IN) :: idof
!! global degree of freedom number
- END SUBROUTINE obj_set11
+ END SUBROUTINE obj_Set11
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -257,10 +257,10 @@ END SUBROUTINE obj_set11
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set12(obj, dofobj, nodenum, VALUE, ivar, idof)
+ MODULE PURE SUBROUTINE obj_Set12(obj, dofobj, nodenum, VALUE, ivar, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -274,7 +274,7 @@ MODULE PURE SUBROUTINE obj_set12(obj, dofobj, nodenum, VALUE, ivar, idof)
!! physical variable number
INTEGER(I4B), INTENT(IN) :: idof
!! local degree of freedom number in physical variable
- END SUBROUTINE obj_set12
+ END SUBROUTINE obj_Set12
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -283,10 +283,10 @@ END SUBROUTINE obj_set12
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set13(obj, dofobj, nodenum, VALUE, ivar, idof)
+ MODULE PURE SUBROUTINE obj_Set13(obj, dofobj, nodenum, VALUE, ivar, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
!! obj(nodenum)=VALUE
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -299,7 +299,7 @@ MODULE PURE SUBROUTINE obj_set13(obj, dofobj, nodenum, VALUE, ivar, idof)
!! physical variable number
INTEGER(I4B), INTENT(IN) :: idof
!! local degree of freedom number in physical variable
- END SUBROUTINE obj_set13
+ END SUBROUTINE obj_Set13
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -308,10 +308,10 @@ END SUBROUTINE obj_set13
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set14(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set14(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -327,7 +327,7 @@ MODULE PURE SUBROUTINE obj_set14(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo
!! time component number
- END SUBROUTINE obj_set14
+ END SUBROUTINE obj_Set14
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -336,10 +336,10 @@ END SUBROUTINE obj_set14
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set15(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set15(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -354,7 +354,7 @@ MODULE PURE SUBROUTINE obj_set15(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo
!! time component number
- END SUBROUTINE obj_set15
+ END SUBROUTINE obj_Set15
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -363,10 +363,10 @@ END SUBROUTINE obj_set15
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set16(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set16(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -382,7 +382,7 @@ MODULE PURE SUBROUTINE obj_set16(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo(:)
!! time component number
- END SUBROUTINE obj_set16
+ END SUBROUTINE obj_Set16
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -391,10 +391,10 @@ END SUBROUTINE obj_set16
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set17(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set17(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -409,7 +409,7 @@ MODULE PURE SUBROUTINE obj_set17(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo(:)
!! time component number
- END SUBROUTINE obj_set17
+ END SUBROUTINE obj_Set17
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -418,10 +418,10 @@ END SUBROUTINE obj_set17
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set18(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set18(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -437,7 +437,7 @@ MODULE PURE SUBROUTINE obj_set18(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number of physical variable
INTEGER(I4B), INTENT(IN) :: timecompo
!! time component number of physical variable
- END SUBROUTINE obj_set18
+ END SUBROUTINE obj_Set18
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -446,10 +446,10 @@ END SUBROUTINE obj_set18
!> author: Vikas Sharma, Ph. D.
! date: 27 June 2021
-! summary: See [[DOF_Method::dof_set2]]
+! summary: See [[DOF_Method::dof_Set2]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set19(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set19(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -464,7 +464,7 @@ MODULE PURE SUBROUTINE obj_set19(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number of physical variable
INTEGER(I4B), INTENT(IN) :: timecompo
!! time component number of physical variable
- END SUBROUTINE obj_set19
+ END SUBROUTINE obj_Set19
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -473,10 +473,10 @@ END SUBROUTINE obj_set19
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set20(obj, dofobj, nodenum, VALUE)
+ MODULE PURE SUBROUTINE obj_Set20(obj, dofobj, nodenum, VALUE)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! degree of freedom object
@@ -484,7 +484,7 @@ MODULE PURE SUBROUTINE obj_set20(obj, dofobj, nodenum, VALUE)
!! node number to set the value
REAL(DFP), INTENT(IN) :: VALUE
!! scalar value
- END SUBROUTINE obj_set20
+ END SUBROUTINE obj_Set20
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -493,10 +493,10 @@ END SUBROUTINE obj_set20
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set21(obj, dofobj, nodenum, VALUE, idof)
+ MODULE PURE SUBROUTINE obj_Set21(obj, dofobj, nodenum, VALUE, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! degree of freedom object
@@ -506,7 +506,7 @@ MODULE PURE SUBROUTINE obj_set21(obj, dofobj, nodenum, VALUE, idof)
!! scalar value
INTEGER(I4B), INTENT(IN) :: idof
!! global degree of freedom number
- END SUBROUTINE obj_set21
+ END SUBROUTINE obj_Set21
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -515,10 +515,10 @@ END SUBROUTINE obj_set21
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set22(obj, dofobj, nodenum, VALUE, ivar, idof)
+ MODULE PURE SUBROUTINE obj_Set22(obj, dofobj, nodenum, VALUE, ivar, idof)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
!! degree of freedom object
@@ -530,7 +530,7 @@ MODULE PURE SUBROUTINE obj_set22(obj, dofobj, nodenum, VALUE, ivar, idof)
!! physical variable number
INTEGER(I4B), INTENT(IN) :: idof
!! local degree of freedom number in physical variable
- END SUBROUTINE obj_set22
+ END SUBROUTINE obj_Set22
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -539,10 +539,10 @@ END SUBROUTINE obj_set22
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set23(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set23(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -557,7 +557,7 @@ MODULE PURE SUBROUTINE obj_set23(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo
!! time component number
- END SUBROUTINE obj_set23
+ END SUBROUTINE obj_Set23
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -566,10 +566,10 @@ END SUBROUTINE obj_set23
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set24(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set24(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -584,7 +584,7 @@ MODULE PURE SUBROUTINE obj_set24(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo(:)
!! time component number
- END SUBROUTINE obj_set24
+ END SUBROUTINE obj_Set24
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -593,10 +593,10 @@ END SUBROUTINE obj_set24
!> author: Vikas Sharma, Ph. D.
! date: 26 June 2021
-! summary: See [[DOF_Method::dof_set1]]
+! summary: See [[DOF_Method::dof_Set1]]
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set25(obj, dofobj, nodenum, VALUE, ivar, &
+ MODULE PURE SUBROUTINE obj_Set25(obj, dofobj, nodenum, VALUE, ivar, &
spacecompo, timecompo)
TYPE(Realvector_), INTENT(INOUT) :: obj
TYPE(DOF_), INTENT(IN) :: dofobj
@@ -611,7 +611,7 @@ MODULE PURE SUBROUTINE obj_set25(obj, dofobj, nodenum, VALUE, ivar, &
!! space component number
INTEGER(I4B), INTENT(IN) :: timecompo
!! time component number
- END SUBROUTINE obj_set25
+ END SUBROUTINE obj_Set25
END INTERFACE Set
!----------------------------------------------------------------------------
@@ -623,10 +623,150 @@ END SUBROUTINE obj_set25
! summary: obj1=obj2
INTERFACE Set
- MODULE PURE SUBROUTINE obj_set26(obj, VALUE)
- CLASS(RealVector_), INTENT(INOUT) :: obj
- CLASS(RealVector_), INTENT(IN) :: VALUE
- END SUBROUTINE obj_set26
+ MODULE PURE SUBROUTINE obj_Set26(obj, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ TYPE(RealVector_), INTENT(IN) :: VALUE
+ END SUBROUTINE obj_Set26
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-29
+! summary: obj = Value
+!
+!# Introduction
+!
+! Value contains the nodal values of all dofs
+! Number of cols in values should be at least equal to the total dof in obj
+! Number of rows in values should be at least equal to the total nodes in obj
+
+INTERFACE Set
+ MODULE SUBROUTINE obj_Set27(obj, dofobj, VALUE)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ REAL(DFP), INTENT(IN) :: VALUE(:, :)
+ !! number of cols should be equal to the total dof in obj
+ !! number of rows should be equal to the total nodes in obj
+ END SUBROUTINE obj_Set27
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-29
+! summary: obj = obj + scale*VALUE
+
+INTERFACE Set
+ MODULE SUBROUTINE obj_Set28(obj, dofobj, VALUE, idof)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! number of cols should be equal to the total dof in obj
+ !! number of rows should be equal to the total nodes in obj
+ INTEGER(I4B), INTENT(IN) :: idof
+ !! global degree of freedom in dofobj
+ END SUBROUTINE obj_Set28
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-29
+! summary: obj = obj + scale*VALUE
+
+INTERFACE Set
+ MODULE SUBROUTINE obj_Set29(obj1, dofobj1, idof1, obj2, dofobj2, idof2)
+ TYPE(RealVector_), INTENT(INOUT) :: obj1
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj1
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: idof1
+ !! global degree of freedom in dof1
+ TYPE(RealVector_), INTENT(IN) :: obj2
+ !! real vector
+ TYPE(DOF_), INTENT(IN) :: dofobj2
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: idof2
+ !! global degree of freedom in dof2
+ END SUBROUTINE obj_Set29
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-30
+! summary: Set range of values to a scalar
+
+INTERFACE Set
+ MODULE SUBROUTINE obj_Set30(obj, dofobj, istart, iend, stride, VALUE, idof)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: VALUE
+ !! Scalar value
+ INTEGER(I4B), INTENT(IN) :: idof
+ !! global degree of freedom number
+ END SUBROUTINE obj_Set30
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-30
+! summary: Set range of values to a vector
+
+INTERFACE Set
+ MODULE SUBROUTINE obj_Set31(obj, dofobj, istart, iend, stride, VALUE, idof)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ !! ob(istart:iend:stride)=VALUE
+ TYPE(DOF_), INTENT(IN) :: dofobj
+ !! degree of freedom object
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! vector value
+ INTEGER(I4B), INTENT(IN) :: idof
+ !! global degree of freedom number
+ END SUBROUTINE obj_Set31
+END INTERFACE Set
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-05-30
+! summary: Set range of values to a vector
+
+INTERFACE Set
+ MODULE SUBROUTINE obj_Set32(obj, istart, iend, stride, VALUE, &
+ istart_value, iend_value, stride_value)
+ TYPE(RealVector_), INTENT(INOUT) :: obj
+ !! ob(istart:iend:stride)=VALUE
+ INTEGER(I4B), INTENT(IN) :: istart, iend, stride
+ !! range of values to set
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ !! vector value
+ INTEGER(I4B), INTENT(IN) :: istart_value, iend_value, stride_value
+ !! range of values to set
+ END SUBROUTINE obj_Set32
END INTERFACE Set
END MODULE RealVector_SetMethods
diff --git a/src/modules/STForceVector/src/STForceVector_Method.F90 b/src/modules/STForceVector/src/STForceVector_Method.F90
index ca9504944..eb434cf46 100644
--- a/src/modules/STForceVector/src/STForceVector_Method.F90
+++ b/src/modules/STForceVector/src/STForceVector_Method.F90
@@ -16,12 +16,14 @@
!
MODULE STForceVector_Method
-USE BaseType
-USE GlobalData
+USE BaseType, ONLY: ElemShapeData_, STElemShapeData_, FEVariable_
+USE BaseType, ONLY: FEVariableScalar_, FEVariableVector_, FEVariableMatrix_
+USE GlobalData, ONLY: I4B, DFP, LGT
IMPLICIT NONE
PRIVATE
PUBLIC :: STForceVector
+PUBLIC :: STForceVector_
!----------------------------------------------------------------------------
! STForceVector
@@ -32,16 +34,58 @@ MODULE STForceVector_Method
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_1(test) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
+ MODULE PURE FUNCTION obj_STForceVector1(test) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_1
+ END FUNCTION obj_STForceVector1
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_1
+ MODULE PROCEDURE obj_STForceVector1
END INTERFACE STForceVector
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_1(test, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_1
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_1
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_22(testSpace, testTime, ans, &
+ nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: testSpace
+ CLASS(ElemshapeData_), INTENT(IN) :: testTime
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_22
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_22
+END INTERFACE STForceVector_
+
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
@@ -51,137 +95,320 @@ END FUNCTION STForceVector_1
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_2(test, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableScalar_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector2(test, c, crank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_2
+ END FUNCTION obj_STForceVector2
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_2
+ MODULE PROCEDURE obj_STForceVector2
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_2(test, c, crank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_2
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_2
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_23( &
+ testSpace, testTime, c, crank, ans, nrow, ncol)
+ CLASS(ElemshapeData_), INTENT(IN) :: testSpace
+ CLASS(ElemshapeData_), INTENT(IN) :: testTime
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_23
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_23
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_3(test, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableVector_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector3(test, c, crank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION STForceVector_3
+ END FUNCTION obj_STForceVector3
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_3
+ MODULE PROCEDURE obj_STForceVector3
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_3( &
+ test, c, crank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE obj_STForceVector_3
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_3
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_24( &
+ testSpace, testTime, c, crank, ans, &
+ dim1, dim2, dim3)
+ CLASS(ElemshapeData_), INTENT(IN) :: testSpace
+ CLASS(ElemshapeData_), INTENT(IN) :: testTime
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE obj_STForceVector_24
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_24
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_4(test, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableMatrix_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector4(test, c, crank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :, :, :)
- END FUNCTION STForceVector_4
+ END FUNCTION obj_STForceVector4
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_4
+ MODULE PROCEDURE obj_STForceVector4
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_4( &
+ test, c, crank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE obj_STForceVector_4
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_4
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_5(test, c1, c1rank, c2, c2rank) &
- & RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector5(test, c1, c1rank, c2, c2rank) &
+ RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_5
+ END FUNCTION obj_STForceVector5
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_5
+ MODULE PROCEDURE obj_STForceVector5
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_5( &
+ test, c1, c1rank, c2, c2rank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_5
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_5
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_6(test, c1, c1rank, c2, c2rank) &
- & RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank
- TYPE(FEVariableVector_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector6(test, c1, c1rank, c2, c2rank) &
+ RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION STForceVector_6
+ END FUNCTION obj_STForceVector6
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_6
+ MODULE PROCEDURE obj_STForceVector6
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_6( &
+ test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE obj_STForceVector_6
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_6
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_7(test, c1, c1rank, c2, c2rank) &
- & RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank
- TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector7(test, c1, c1rank, c2, c2rank) &
+ RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :, :)
- END FUNCTION STForceVector_7
+ END FUNCTION obj_STForceVector7
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_7
+ MODULE PROCEDURE obj_STForceVector7
END INTERFACE STForceVector
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_7( &
+ test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE obj_STForceVector_7
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_7
+END INTERFACE STForceVector_
+
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
@@ -191,17 +418,38 @@ END FUNCTION STForceVector_7
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_8(test, term1) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
+ MODULE PURE FUNCTION obj_STForceVector8(test, term1) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_8
+ END FUNCTION obj_STForceVector8
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_8
+ MODULE PROCEDURE obj_STForceVector8
END INTERFACE STForceVector
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_8(test, term1, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_8
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_8
+END INTERFACE STForceVector_
+
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
@@ -211,143 +459,287 @@ END FUNCTION STForceVector_8
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_9(test, term1, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableScalar_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector9(test, term1, c, crank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_9
+ END FUNCTION obj_STForceVector9
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_9
+ MODULE PROCEDURE obj_STForceVector9
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_9( &
+ test, term1, c, crank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_9
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_9
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_10(test, term1, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableVector_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector10(test, term1, c, crank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION STForceVector_10
+ END FUNCTION obj_STForceVector10
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_10
+ MODULE PROCEDURE obj_STForceVector10
END INTERFACE STForceVector
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_10( &
+ test, term1, c, crank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE obj_STForceVector_10
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_10
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_11(test, term1, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableMatrix_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector11(test, term1, c, crank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :, :, :)
- END FUNCTION STForceVector_11
+ END FUNCTION obj_STForceVector11
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_11
+ MODULE PROCEDURE obj_STForceVector11
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_11( &
+ test, term1, c, crank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE obj_STForceVector_11
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_11
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_12(test, term1, c1, c1rank, c2, c2rank)&
- & RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector12( &
+ test, term1, c1, c1rank, c2, c2rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_12
+ END FUNCTION obj_STForceVector12
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_12
+ MODULE PROCEDURE obj_STForceVector12
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_12( &
+ test, term1, c1, c1rank, c2, c2rank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_STForceVector_12
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_12
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_13(test, term1, c1, c1rank, c2, c2rank)&
- & RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank
- TYPE(FEVariableVector_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector13( &
+ test, term1, c1, c1rank, c2, c2rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION STForceVector_13
+ END FUNCTION obj_STForceVector13
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_13
+ MODULE PROCEDURE obj_STForceVector13
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_13( &
+ test, term1, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE obj_STForceVector_13
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_13
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_14(test, term1, c1, c1rank, c2, c2rank)&
- & RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- INTEGER( I4B ), INTENT( IN ) :: term1
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableScalar_), INTENT( IN ) :: c1rank
- TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector14( &
+ test, term1, c1, c1rank, c2, c2rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :, :)
- END FUNCTION STForceVector_14
+ END FUNCTION obj_STForceVector14
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_14
+ MODULE PROCEDURE obj_STForceVector14
END INTERFACE STForceVector
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_14( &
+ test, term1, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE obj_STForceVector_14
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_14
+END INTERFACE STForceVector_
!----------------------------------------------------------------------------
! STForceVector
@@ -358,19 +750,48 @@ END FUNCTION STForceVector_14
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_15(test, projecton, c, crank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c
- TYPE(FEVariableVector_), INTENT( IN ) :: crank
+ MODULE PURE FUNCTION obj_STForceVector15(test, projection, c, crank) &
+ RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_15
+ END FUNCTION obj_STForceVector15
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_15
+ MODULE PROCEDURE obj_STForceVector15
END INTERFACE STForceVector
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Space time force vector
+!
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_15( &
+ test, projection, c, crank, ans, nrow, ncol, temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ !! temp array to keep projection data at ips and ipt
+ !! size should be at least (nns x nnt)
+ END SUBROUTINE obj_STForceVector_15
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_15
+END INTERFACE STForceVector_
+
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
@@ -380,22 +801,51 @@ END FUNCTION STForceVector_15
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_16(test, projecton, c1, c1rank, &
- & c2, c2rank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableVector_), INTENT( IN ) :: c1rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector16( &
+ test, projection, c1, c1rank, c2, c2rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_16
+ END FUNCTION obj_STForceVector16
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_16
+ MODULE PROCEDURE obj_STForceVector16
END INTERFACE STForceVector
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_16( &
+ test, projection, c1, c1rank, c2, c2rank, ans, nrow, ncol, temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ !! temp array to keep projection data at ips and ipt
+ !! size should be at least (nns x nnt)
+ END SUBROUTINE obj_STForceVector_16
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_16
+END INTERFACE STForceVector_
+
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
@@ -405,20 +855,22 @@ END FUNCTION STForceVector_16
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_17(test, projecton, &
- & c1, c1rank, c2, c2rank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableVector_), INTENT( IN ) :: c1rank
- TYPE(FEVariableVector_), INTENT( IN ) :: c2rank
+ MODULE PURE FUNCTION obj_STForceVector17( &
+ test, projection, c1, c1rank, c2, c2rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ !! projection is made on c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ !!
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION STForceVector_17
+ END FUNCTION obj_STForceVector17
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_17
+ MODULE PROCEDURE obj_STForceVector17
END INTERFACE STForceVector
!----------------------------------------------------------------------------
@@ -430,104 +882,255 @@ END FUNCTION STForceVector_17
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_18(test, projecton, &
- & c1, c1rank, c2, c2rank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariableVector_), INTENT( IN ) :: c1rank
- TYPE(FEVariableMatrix_), INTENT( IN ) :: c2rank
+ MODULE PURE SUBROUTINE obj_STForceVector_17( &
+ test, projection, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ !! projection is made on c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ !! c2 force vector
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ END SUBROUTINE obj_STForceVector_17
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_17
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE FUNCTION obj_STForceVector18( &
+ test, projection, c1, c1rank, c2, c2rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :, :)
- END FUNCTION STForceVector_18
+ END FUNCTION obj_STForceVector18
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_18
+ MODULE PROCEDURE obj_STForceVector18
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_18( &
+ test, projection, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3, dim4, &
+ temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ !! projection vector
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ END SUBROUTINE obj_STForceVector_18
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_18
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_19(test, projecton, &
- & c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariable_), INTENT( IN ) :: c3
- TYPE(FEVariableVector_), INTENT( IN ) :: c1rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c3rank
+ MODULE PURE FUNCTION obj_STForceVector19( &
+ test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariable_), INTENT(IN) :: c3
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c3rank
REAL(DFP), ALLOCATABLE :: ans(:, :)
- END FUNCTION STForceVector_19
+ END FUNCTION obj_STForceVector19
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_19
+ MODULE PROCEDURE obj_STForceVector19
END INTERFACE STForceVector
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_19( &
+ test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, nrow, ncol, &
+ temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariable_), INTENT(IN) :: c3
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c3rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ END SUBROUTINE obj_STForceVector_19
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_19
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_20(test, projecton, c1, c1rank, c2, &
- & c2rank, c3, c3rank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariable_), INTENT( IN ) :: c3
- TYPE(FEVariableVector_), INTENT( IN ) :: c1rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank
- TYPE(FEVariableVector_), INTENT( IN ) :: c3rank
+ MODULE PURE FUNCTION obj_STForceVector20( &
+ test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariable_), INTENT(IN) :: c3
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c3rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :)
- END FUNCTION STForceVector_20
+ END FUNCTION obj_STForceVector20
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_20
+ MODULE PROCEDURE obj_STForceVector20
END INTERFACE STForceVector
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_20( &
+ test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, &
+ dim1, dim2, dim3, temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariable_), INTENT(IN) :: c3
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ !! projection on c1
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c3rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ END SUBROUTINE obj_STForceVector_20
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_20
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 20 Jan 2022
! summary: Force vector
INTERFACE
- MODULE PURE FUNCTION STForceVector_21(test, projecton, c1, c1rank, c2, &
- & c2rank, c3, c3rank) RESULT(ans)
- CLASS(STElemshapeData_), INTENT(IN) :: test( : )
- CHARACTER( LEN = * ), INTENT( IN ) :: projecton
- TYPE(FEVariable_), INTENT( IN ) :: c1
- TYPE(FEVariable_), INTENT( IN ) :: c2
- TYPE(FEVariable_), INTENT( IN ) :: c3
- TYPE(FEVariableVector_), INTENT( IN ) :: c1rank
- TYPE(FEVariableScalar_), INTENT( IN ) :: c2rank
- TYPE(FEVariableMatrix_), INTENT( IN ) :: c3rank
+ MODULE PURE FUNCTION obj_STForceVector21( &
+ test, projection, c1, c1rank, c2, c2rank, c3, c3rank) RESULT(ans)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariable_), INTENT(IN) :: c3
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c3rank
REAL(DFP), ALLOCATABLE :: ans(:, :, :, :)
- END FUNCTION STForceVector_21
+ END FUNCTION obj_STForceVector21
END INTERFACE
INTERFACE STForceVector
- MODULE PROCEDURE STForceVector_21
+ MODULE PROCEDURE obj_STForceVector21
END INTERFACE STForceVector
-END MODULE STForceVector_Method
\ No newline at end of file
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 20 Jan 2022
+! summary: Force vector
+
+INTERFACE
+ MODULE PURE SUBROUTINE obj_STForceVector_21( &
+ test, projection, c1, c1rank, c2, c2rank, c3, c3rank, ans, dim1, dim2, &
+ dim3, dim4, temp)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ CHARACTER(LEN=*), INTENT(IN) :: projection
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariable_), INTENT(IN) :: c3
+ TYPE(FEVariableVector_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c3rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ REAL(DFP), INTENT(INOUT) :: temp(:, :)
+ END SUBROUTINE obj_STForceVector_21
+END INTERFACE
+
+INTERFACE STForceVector_
+ MODULE PROCEDURE obj_STForceVector_21
+END INTERFACE STForceVector_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE STForceVector_Method
+
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/String/src/String_Class.F90 b/src/modules/String/src/String_Class.F90
index d186c7b07..cc89858e7 100644
--- a/src/modules/String/src/String_Class.F90
+++ b/src/modules/String/src/String_Class.F90
@@ -312,18 +312,16 @@ MODULE String_Class
PROCEDURE, PASS(self) :: tempname
!! Return a safe temporary name suitable for temporary file
!! or directories.
- GENERIC :: to_number => &
- to_integer_I1P, &
+ GENERIC :: to_number => to_integer_I1P, to_integer_I4P, to_integer_I8P, &
+ to_real_R8P, to_real_R4P, &
#ifndef _NVF
to_integer_I2P, &
#endif
- to_integer_I4P, &
- to_integer_I8P, &
#ifdef _R16P
to_real_R16P, &
#endif
- to_real_R8P, &
- to_real_R4P
+ to_logical_1
+
!! Cast string to number.
PROCEDURE, PASS(self) :: unescape
!! Unescape double backslashes (or custom escaped character).
@@ -475,7 +473,7 @@ MODULE String_Class
!! Cast string to real.
PROCEDURE, PRIVATE, PASS(self) :: to_real_R16P
!! Cast string to real.
- PROCEDURE, PUBLIC, PASS(self) :: to_logical
+ PROCEDURE, PUBLIC, PASS(self) :: to_logical, to_logical_1
!! Convert a string to logical
! assignments
PROCEDURE, PRIVATE, PASS(lhs) :: string_assign_string
@@ -3169,6 +3167,25 @@ END FUNCTION tempname
!
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-05-29
+! summary: Cast string to logical
+
+ELEMENTAL FUNCTION to_logical_1(self, kind) RESULT(ans)
+ CLASS(string), INTENT(IN) :: self
+ !! The string.
+ LOGICAL, INTENT(IN) :: kind
+ !! Mold parameter for kind detection.
+ LOGICAL :: ans
+ !! The number into the string.
+
+ ans = self%to_logical()
+END FUNCTION to_logical_1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
!> author: Vikas Sharma, Ph. D.
! date: 23 July 2022
! summary: Cast string to integer (I1P).
diff --git a/src/modules/Tetrahedron/CMakeLists.txt b/src/modules/Tetrahedron/CMakeLists.txt
new file mode 100644
index 000000000..4aabd5814
--- /dev/null
+++ b/src/modules/Tetrahedron/CMakeLists.txt
@@ -0,0 +1,21 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME} PRIVATE ${src_path}/ReferenceTetrahedron_Method.F90
+ ${src_path}/TetrahedronInterpolationUtility.F90)
diff --git a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90 b/src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90
similarity index 90%
rename from src/modules/Geometry/src/ReferenceTetrahedron_Method.F90
rename to src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90
index 6dd64c981..dfc18fc24 100644
--- a/src/modules/Geometry/src/ReferenceTetrahedron_Method.F90
+++ b/src/modules/Tetrahedron/src/ReferenceTetrahedron_Method.F90
@@ -341,16 +341,19 @@ END FUNCTION RefCoord_Tetrahedron
END INTERFACE
!----------------------------------------------------------------------------
-! GetFaceElemType@GeometryMethods
+! GetFaceElemType@GeometryMethods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
! date: 2024-03-11
! summary: Returns the element type of each face
-INTERFACE
- MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron(faceElemType, opt, &
- & tFaceNodes, elemType)
+INTERFACE GetFaceElemType_Tetrahedron
+ MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron1(elemType, faceElemType, &
+ tFaceNodes, opt)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
+ !! element type for Tetrahedron
+ !! default is Tetrahedron4
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
!! Face element type
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: tFaceNodes(:)
@@ -359,10 +362,33 @@ MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron(faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
+ END SUBROUTINE GetFaceElemType_Tetrahedron1
+END INTERFACE GetFaceElemType_Tetrahedron
+
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-03-11
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Tetrahedron
+ MODULE PURE SUBROUTINE GetFaceElemType_Tetrahedron2( &
+ elemType, localFaceNumber, faceElemType, tFaceNodes, opt)
+ INTEGER(I4B), INTENT(IN) :: elemType
!! element type for Tetrahedron
- !! default is Tetrahedron4
- END SUBROUTINE GetFaceElemType_Tetrahedron
-END INTERFACE
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Face element type
+ INTEGER(I4B), INTENT(OUT) :: tFaceNodes
+ !! total nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Tetrahedron2
+END INTERFACE GetFaceElemType_Tetrahedron
END MODULE ReferenceTetrahedron_Method
diff --git a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90 b/src/modules/Tetrahedron/src/TetrahedronInterpolationUtility.F90
similarity index 61%
rename from src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90
rename to src/modules/Tetrahedron/src/TetrahedronInterpolationUtility.F90
index 1fba7da35..c30160f2b 100644
--- a/src/modules/Polynomial/src/TetrahedronInterpolationUtility.F90
+++ b/src/modules/Tetrahedron/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/Triangle/CMakeLists.txt b/src/modules/Triangle/CMakeLists.txt
new file mode 100644
index 000000000..cfaca3bbf
--- /dev/null
+++ b/src/modules/Triangle/CMakeLists.txt
@@ -0,0 +1,23 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/Triangle_Method.F90
+ ${src_path}/ReferenceTriangle_Method.F90
+ ${src_path}/TriangleInterpolationUtility.F90)
diff --git a/src/modules/Geometry/src/ReferenceTriangle_Method.F90 b/src/modules/Triangle/src/ReferenceTriangle_Method.F90
similarity index 95%
rename from src/modules/Geometry/src/ReferenceTriangle_Method.F90
rename to src/modules/Triangle/src/ReferenceTriangle_Method.F90
index 2e71a0e39..83e9ddf94 100644
--- a/src/modules/Geometry/src/ReferenceTriangle_Method.F90
+++ b/src/modules/Triangle/src/ReferenceTriangle_Method.F90
@@ -802,9 +802,9 @@ END SUBROUTINE FaceShapeMetaData_Triangle
! date: 2024-04-19
! summary: Returns the element type of each face
-INTERFACE
-MODULE PURE SUBROUTINE GetFaceElemType_Triangle(elemType, faceElemType, opt, &
- tFaceNodes)
+INTERFACE GetFaceElemType_Triangle
+MODULE PURE SUBROUTINE GetFaceElemType_Triangle1(elemType, faceElemType, opt, &
+ tFaceNodes)
INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
!! name of element
INTEGER(I4B), OPTIONAL, INTENT(INOUT) :: faceElemType(:)
@@ -815,8 +815,34 @@ MODULE PURE SUBROUTINE GetFaceElemType_Triangle(elemType, faceElemType, opt, &
!! If opt = 1, then edge connectivity for hierarchial approximation
!! If opt = 2, then edge connectivity for Lagrangian approximation
!! opt = 1 is default
- END SUBROUTINE GetFaceElemType_Triangle
-END INTERFACE
+ END SUBROUTINE GetFaceElemType_Triangle1
+END INTERFACE GetFaceElemType_Triangle
+
+!----------------------------------------------------------------------------
+! GetFaceElemType@GeometryMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-04-19
+! summary: Returns the element type of each face
+
+INTERFACE GetFaceElemType_Triangle
+ MODULE PURE SUBROUTINE GetFaceElemType_Triangle2(elemType, localFaceNumber, &
+ faceElemType, opt, tFaceNodes)
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: elemType
+ !! name of element
+ INTEGER(I4B), INTENT(IN) :: localFaceNumber
+ !! local face number
+ INTEGER(I4B), INTENT(OUT) :: faceElemType
+ !! Element names of faces
+ INTEGER(I4B), INTENT(OUT) :: tFaceNodes
+ !! Total number of nodes in each face
+ INTEGER(I4B), OPTIONAL, INTENT(IN) :: opt
+ !! If opt = 1, then edge connectivity for hierarchial approximation
+ !! If opt = 2, then edge connectivity for Lagrangian approximation
+ !! opt = 1 is default
+ END SUBROUTINE GetFaceElemType_Triangle2
+END INTERFACE GetFaceElemType_Triangle
!----------------------------------------------------------------------------
!
diff --git a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90 b/src/modules/Triangle/src/TriangleInterpolationUtility.F90
similarity index 67%
rename from src/modules/Polynomial/src/TriangleInterpolationUtility.F90
rename to src/modules/Triangle/src/TriangleInterpolationUtility.F90
index 463931d91..fbe3299d9 100644
--- a/src/modules/Polynomial/src/TriangleInterpolationUtility.F90
+++ b/src/modules/Triangle/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,35 @@ MODULE TriangleInterpolationUtility
PUBLIC :: GetTotalDOF_Triangle
PUBLIC :: GetTotalInDOF_Triangle
-! PUBLIC :: BarycentricVertexBasis_Triangle
-! PUBLIC :: BarycentricEdgeBasis_Triangle
-! PUBLIC :: BarycentricHeirarchicalBasis_Triangle
-! PUBLIC :: BarycentricHeirarchicalBasisGradient_Triangle
+PUBLIC :: GetHierarchicalDOF_Triangle
+
+!----------------------------------------------------------------------------
+! GetHierarchicalDOF_Triangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-18
+! summary: Get the Hierarchical DOF for triangle
+
+! order, pe1, pe2, pe3
+INTERFACE
+ MODULE PURE FUNCTION GetHierarchicalDOF_Triangle( &
+ order, pe1, pe2, pe3, opt) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! cell order
+ INTEGER(I4B), INTENT(IN) :: pe1, pe2, pe3
+ !! face order
+ CHARACTER(1), INTENT(IN) :: opt
+ !! 'V' - vertex
+ !! 'E' - edge
+ !! 'C' - cell
+ !! 'H' - total hierarchical dof
+ INTEGER(I4B) :: ans
+ END FUNCTION GetHierarchicalDOF_Triangle
+END INTERFACE
!----------------------------------------------------------------------------
-! GetTotalDOF_Triangle
+! GetTotalDOF_Triangle
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -107,7 +150,7 @@ END FUNCTION GetTotalInDOF_Triangle
INTERFACE
MODULE FUNCTION RefElemDomain_Triangle(baseContinuity, baseInterpol) &
- & RESULT(ans)
+ RESULT(ans)
CHARACTER(*), INTENT(IN) :: baseContinuity
!! Cointinuity (conformity) of basis functions
!! "H1", "HDiv", "HCurl", "DG"
@@ -128,11 +171,10 @@ END FUNCTION RefElemDomain_Triangle
! summary: This function returns the edge connectivity of Triangle
INTERFACE
- MODULE FUNCTION FacetConnectivity_Triangle( &
- & baseInterpol, &
- & baseContinuity) RESULT(ans)
- CHARACTER(*), INTENT(IN) :: baseInterpol
- CHARACTER(*), INTENT(IN) :: baseContinuity
+ MODULE FUNCTION FacetConnectivity_Triangle(baseInterpol, &
+ baseContinuity) RESULT(ans)
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: baseInterpol
+ CHARACTER(*), OPTIONAL, INTENT(IN) :: baseContinuity
INTEGER(I4B) :: ans(2, 3)
!! rows represents the end points of an edges
!! columns denote the edge (facet)
@@ -147,7 +189,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 +296,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 +356,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 +393,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 +416,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 +456,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 +480,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 +543,8 @@ 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 +564,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 +613,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 +657,28 @@ 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 +702,26 @@ 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
!----------------------------------------------------------------------------
@@ -496,12 +738,9 @@ MODULE FUNCTION LagrangeCoeff_Triangle4(order, xij, basisType, &
REAL(DFP), INTENT(IN) :: xij(:, :)
!! points in xij format, size(xij,2)
INTEGER(I4B), OPTIONAL, INTENT(IN) :: basisType
- !! Monomials
- !! Jacobi (Dubiner)
- !! Heirarchical
+ !! Monomials ! Jacobi (Dubiner) ! Heirarchical
CHARACTER(*), OPTIONAL, INTENT(IN) :: refTriangle
- !! UNIT
- !! BIUNIT
+ !! UNIT ! BIUNIT
REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2))
!! coefficients
END FUNCTION LagrangeCoeff_Triangle4
@@ -523,12 +762,9 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle4_(order, xij, basisType, &
REAL(DFP), INTENT(IN) :: xij(:, :)
!! points in xij format, size(xij,2)
INTEGER(I4B), INTENT(IN) :: basisType
- !! Monomials
- !! Jacobi (Dubiner)
- !! Heirarchical
+ !! Monomials ! Jacobi (Dubiner) ! Heirarchical
CHARACTER(*), INTENT(IN) :: refTriangle
- !! UNIT
- !! BIUNIT
+ !! UNIT ! BIUNIT
REAL(DFP), INTENT(INOUT) :: ans(:, :)
! REAL(DFP) :: ans(SIZE(xij, 2), SIZE(xij, 2))
!! coefficients
@@ -536,6 +772,57 @@ MODULE SUBROUTINE LagrangeCoeff_Triangle4_(order, xij, basisType, &
END SUBROUTINE LagrangeCoeff_Triangle4_
END INTERFACE LagrangeCoeff_Triangle_
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 27 Oct 2022
+! summary: Returns the coefficients for ith lagrange polynomial
+
+INTERFACE LagrangeCoeff_Triangle_
+ MODULE SUBROUTINE LagrangeCoeff_Triangle5_( &
+ order, xij, basisType, refTriangle, degree, 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), INTENT(IN) :: basisType
+ !! Monomials, Jacobi (Dubiner), Hierarchical
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! UNIT, BIUNIT
+ INTEGER(I4B), INTENT(IN) :: degree(:, :)
+ !! degree of monomials, used when basisType is Monomial
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! ans(SIZE(xij, 2), SIZE(xij, 2))
+ !! coefficients
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE LagrangeCoeff_Triangle5_
+END INTERFACE LagrangeCoeff_Triangle_
+
+!----------------------------------------------------------------------------
+! LagrangeVandermonde_Triangle
+!----------------------------------------------------------------------------
+
+INTERFACE LagrangeVandermonde_Triangle_
+ MODULE PURE SUBROUTINE LagrangeVandermonde_Triangle1_(xij, degree, ans, &
+ nrow, ncol)
+ REAL(DFP), INTENT(IN) :: xij(:, :)
+ !! points in $x_{iJ}$ format
+ !! nrow = number of spatial dimensions
+ !! ncol = number of points of evaluation
+ INTEGER(I4B), INTENT(IN) :: degree(:, :)
+ !! degree of monomials
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! Vandermonde matrix
+ !! nrows := number of points
+ !! ncols := number of dof
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! nrow = SIZE(xij, 2)
+ !! ncol = SIZE(degree, 1)
+ END SUBROUTINE LagrangeVandermonde_Triangle1_
+END INTERFACE LagrangeVandermonde_Triangle_
+
!----------------------------------------------------------------------------
! DubinerPolynomial
!----------------------------------------------------------------------------
@@ -653,6 +940,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 +1017,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 +1040,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 +1056,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 +1071,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
!----------------------------------------------------------------------------
@@ -873,77 +1096,16 @@ END FUNCTION CellBasis_Triangle
END INTERFACE
!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasis_Triangle
+! HeirarchicalBasis_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
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 27 Oct 2022
-! 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)
+INTERFACE HeirarchicalBasis_Triangle
+ 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
@@ -1006,8 +1168,8 @@ END FUNCTION HeirarchicalBasis_Triangle2
! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
INTERFACE HeirarchicalBasis_Triangle_
- MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle1_(order, pe1, pe2, pe3, &
- xij, refTriangle, ans, nrow, ncol)
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle1_( &
+ order, pe1, pe2, pe3, xij, refTriangle, ans, nrow, ncol)
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
@@ -1045,8 +1207,8 @@ END SUBROUTINE HeirarchicalBasis_Triangle1_
! summary: Evaluate all modal basis (heirarchical polynomial) on Triangle
INTERFACE HeirarchicalBasis_Triangle_
- MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle2_(order, xij, &
- refTriangle, ans, nrow, ncol)
+ MODULE PURE SUBROUTINE HeirarchicalBasis_Triangle2_( &
+ order, xij, refTriangle, ans, nrow, ncol)
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 +1229,47 @@ 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
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> 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
+! date: 2024-07-04
+! summary: Evaluate all modal basis (heirarchical polynomial) 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)
- !!
- END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1
-END INTERFACE BarycentricHeirarchicalBasisGradient_Triangle
+ ! & SIZE(xij, 2), &
+ ! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2))
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE HeirarchicalBasis_Triangle3_
+END INTERFACE HeirarchicalBasis_Triangle_
!----------------------------------------------------------------------------
! LagrangeEvalAll_Triangle
@@ -1179,13 +1281,7 @@ END SUBROUTINE BarycentricHeirarchicalBasisGradient_Triangle1
INTERFACE LagrangeEvalAll_Triangle
MODULE FUNCTION LagrangeEvalAll_Triangle1( &
- & order, &
- & x, &
- & xij, &
- & refTriangle, &
- & coeff, &
- & firstCall, &
- & basisType) RESULT(ans)
+ 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 +1307,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
!----------------------------------------------------------------------------
@@ -1221,14 +1353,8 @@ END FUNCTION LagrangeEvalAll_Triangle1
INTERFACE LagrangeEvalAll_Triangle
MODULE FUNCTION LagrangeEvalAll_Triangle2( &
- & order, &
- & x, &
- & xij, &
- & refTriangle, &
- & coeff, &
- & firstCall, &
- & basisType, &
- & alpha, beta, lambda) RESULT(ans)
+ 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 +1383,105 @@ 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_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Triangle_@LagrangeMethods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-22
+! summary: Master routine for LagrangeEvalAll_Triangle_
+
+INTERFACE LagrangeEvalAll_Triangle_
+ MODULE SUBROUTINE LagrangeEvalAll_Triangle3_( &
+ order, x, xij, ans, nrow, ncol, refTriangle, coeff, firstCall, &
+ basisType, xx, degree)
+ 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
+ !! nrow = size(x, 2), points of evaluation
+ !! ncol = size(xij, 2), number of interpolation points
+ CHARACTER(*), INTENT(IN) :: refTriangle
+ !! Reference triangle ! Biunit ! Unit
+ REAL(DFP), INTENT(INOUT) :: coeff(:, :)
+ !! coeff(SIZE(xij, 2), SIZE(xij, 2))
+ !! Coefficient of Lagrange polynomials
+ LOGICAL(LGT) :: 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), INTENT(IN) :: basisType
+ !! Monomials *Default ! Jacobi=Dubiner ! Heirarchical
+ REAL(DFP), INTENT(INOUT) :: xx(:, :)
+ !! xx(SIZE(x, 2), SIZE(xij, 2))
+ INTEGER(I4B) :: degree(:, :)
+ ! degree(SIZE(xij, 2), 2)
+ END SUBROUTINE LagrangeEvalAll_Triangle3_
+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 +1500,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 +1511,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 +1558,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 +1568,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 +1625,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
!----------------------------------------------------------------------------
@@ -1358,7 +1660,7 @@ END FUNCTION TensorQuadraturePoint_Triangle1
INTERFACE TensorQuadraturePoint_Triangle
MODULE FUNCTION TensorQuadraturePoint_Triangle2(nipsx, nipsy, quadType, &
- & refTriangle, xij) RESULT(ans)
+ & refTriangle, xij) RESULT(ans)
INTEGER(I4B), INTENT(IN) :: nipsx(1)
!! number of integration points in x direction
INTEGER(I4B), INTENT(IN) :: nipsy(1)
@@ -1380,12 +1682,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 +1765,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 +1825,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 +1861,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 +1883,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 +1971,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/Geometry/src/Triangle_Method.F90 b/src/modules/Triangle/src/Triangle_Method.F90
similarity index 99%
rename from src/modules/Geometry/src/Triangle_Method.F90
rename to src/modules/Triangle/src/Triangle_Method.F90
index 62db70829..63222c801 100644
--- a/src/modules/Geometry/src/Triangle_Method.F90
+++ b/src/modules/Triangle/src/Triangle_Method.F90
@@ -29,7 +29,7 @@
! easifem.
MODULE Triangle_Method
-USE GlobalData
+USE GlobalData, ONLY: I4B, LGT, DFP
IMPLICIT NONE
PRIVATE
PUBLIC :: triangle_angles_2d
diff --git a/src/modules/Utility/CMakeLists.txt b/src/modules/Utility/CMakeLists.txt
index 3428baa00..60fcc22cc 100644
--- a/src/modules/Utility/CMakeLists.txt
+++ b/src/modules/Utility/CMakeLists.txt
@@ -53,4 +53,5 @@ target_sources(
${src_path}/TriagUtility.F90
${src_path}/LinearAlgebraUtility.F90
${src_path}/SafeSizeUtility.F90
+ ${src_path}/ReverseUtility.F90
${src_path}/Utility.F90)
diff --git a/src/modules/Utility/src/ConvertUtility.F90 b/src/modules/Utility/src/ConvertUtility.F90
index 9deec4303..bcb54a384 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
!----------------------------------------------------------------------------
@@ -49,17 +50,41 @@ MODULE ConvertUtility
!@endnote
INTERFACE Convert
- MODULE PURE SUBROUTINE convert_1(From, To, Conversion, nns, tdof)
- REAL(DFP), INTENT(IN) :: From(:, :)
+ MODULE PURE SUBROUTINE obj_Convert1(from, to, conversion, nns, tdof)
+ REAL(DFP), INTENT(IN) :: from(:, :)
!! Matrix in one format
- REAL(DFP), INTENT(INOUT), ALLOCATABLE :: To(:, :)
+ REAL(DFP), INTENT(INOUT), ALLOCATABLE :: to(:, :)
!! Matrix is desired format
- INTEGER(I4B), INTENT(IN) :: Conversion
- !! `Conversion` can be `NodesToDOF` or `DOFToNodes`
+ INTEGER(I4B), INTENT(IN) :: conversion
+ !! `conversion` can be `NodestoDOF` or `DOFtoNodes`
INTEGER(I4B), INTENT(IN) :: nns, tdof
- END SUBROUTINE convert_1
+ END SUBROUTINE obj_Convert1
END INTERFACE Convert
+!----------------------------------------------------------------------------
+! Convert_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-11-20
+! summary: Like Convert_1, but no allocation
+
+INTERFACE Convert_
+ MODULE PURE SUBROUTINE obj_Convert_1(from, to, conversion, nns, tdof, nrow, &
+ ncol)
+ REAL(DFP), INTENT(IN) :: from(:, :)
+ !! Matrix in one format
+ REAL(DFP), INTENT(INOUT) :: to(:, :)
+ !! Matrix is desired format
+ INTEGER(I4B), INTENT(IN) :: conversion
+ !! `conversion` can be `NodestoDOF` or `DOFtoNodes`
+ INTEGER(I4B), INTENT(IN) :: nns, tdof
+ !! number of nodes in space and tdod
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ !! number of data written in to
+ END SUBROUTINE obj_Convert_1
+END INTERFACE Convert_
+
!----------------------------------------------------------------------------
! Convert@ConvertMethods
!----------------------------------------------------------------------------
@@ -86,15 +111,15 @@ END SUBROUTINE convert_1
!@endnote
INTERFACE ConvertSafe
- MODULE PURE SUBROUTINE convert_1_safe(From, To, Conversion, nns, tdof)
- REAL(DFP), INTENT(IN) :: From(:, :)
+ MODULE PURE SUBROUTINE obj_ConvertSafe1(from, to, conversion, nns, tdof)
+ REAL(DFP), INTENT(IN) :: from(:, :)
!! Matrix in one format
- REAL(DFP), INTENT(INOUT) :: To(:, :)
+ REAL(DFP), INTENT(INOUT) :: to(:, :)
!! Matrix is desired format
- INTEGER(I4B), INTENT(IN) :: Conversion
- !! `Conversion` can be `NodesToDOF` or `DOFToNodes`
+ INTEGER(I4B), INTENT(IN) :: conversion
+ !! `conversion` can be `NodestoDOF` or `DOFtoNodes`
INTEGER(I4B), INTENT(IN) :: nns, tdof
- END SUBROUTINE convert_1_safe
+ END SUBROUTINE obj_ConvertSafe1
END INTERFACE ConvertSafe
!----------------------------------------------------------------------------
@@ -110,22 +135,38 @@ END SUBROUTINE convert_1_safe
! This subroutine converts rank4 matrix to rank2 matrix
! This routine can be used in Space-Time FEM
!
-! - The first and second dimension of From is spatial nodes
-! - The third and forth dimension of From is temporal nodes
+! - The first and second dimension of from is spatial nodes
+! - The third and forth dimension of from is temporal nodes
!
-! - In this way `From(:, :, a, b)` denotes the `a,b` block matrix
+! - In this way `from(:, :, a, b)` denotes the `a,b` block matrix
!
-! Format of To matrix
+! Format of to matrix
!
! Contains the block matrix structure in 2D.
INTERFACE Convert
- MODULE PURE SUBROUTINE convert_2(From, To)
- REAL(DFP), INTENT(IN) :: From(:, :, :, :)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :)
- END SUBROUTINE convert_2
+ MODULE PURE SUBROUTINE obj_Convert2(from, to)
+ REAL(DFP), INTENT(IN) :: from(:, :, :, :)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :)
+ END SUBROUTINE obj_Convert2
END INTERFACE Convert
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: convert without allocation
+
+INTERFACE Convert_
+ MODULE PURE SUBROUTINE obj_Convert_2(from, to, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: from(:, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: to(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE obj_Convert_2
+END INTERFACE Convert_
+
!----------------------------------------------------------------------------
! Convert@ConvertMethods
!----------------------------------------------------------------------------
@@ -136,16 +177,32 @@ END SUBROUTINE convert_2
!
INTERFACE Convert
- MODULE PURE SUBROUTINE convert_3(From, To)
- REAL(DFP), INTENT(IN) :: From(:, :, :, :, :, :)
+ MODULE PURE SUBROUTINE obj_Convert3(from, to)
+ REAL(DFP), INTENT(IN) :: from(:, :, :, :, :, :)
!! I, J, ii, jj, a, b
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: To(:, :, :, :)
+ REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: to(:, :, :, :)
!! I, J, a, b
- END SUBROUTINE convert_3
+ END SUBROUTINE obj_Convert3
END INTERFACE Convert
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
+!> author: Shion Shimizu
+! date: 2025-03-03
+! summary: convert without allocation
+
+INTERFACE Convert_
+ MODULE PURE SUBROUTINE obj_Convert_3(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 obj_Convert_3
+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/MatmulUtility.F90 b/src/modules/Utility/src/MatmulUtility.F90
index 1fb96640e..0e873f488 100644
--- a/src/modules/Utility/src/MatmulUtility.F90
+++ b/src/modules/Utility/src/MatmulUtility.F90
@@ -16,11 +16,12 @@
!
MODULE MatmulUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, I4B, LGT
IMPLICIT NONE
PRIVATE
PUBLIC :: MATMUL
+PUBLIC :: MATMUL_
!----------------------------------------------------------------------------
! Matmul@Matmul
@@ -38,7 +39,7 @@ MODULE MatmulUtility
MODULE PURE FUNCTION matmul_r4_r1(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
REAL(DFP), INTENT(IN) :: a2(:)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3))
END FUNCTION
END INTERFACE
@@ -46,6 +47,31 @@ MODULE PURE FUNCTION matmul_r4_r1(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r4_r1
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 3 April 2021
+! summary: matmul for rank4 and rank1 array
+!
+!# Introduction
+!
+! `ans(i,j,k) = a1(i,j,k,l)*a2(l)`
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r4_r1_(a1, a2, ans, dim1, dim2, dim3)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matmul_r4_r1_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r4_r1_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -61,8 +87,8 @@ MODULE PURE FUNCTION matmul_r4_r1(a1, a2) RESULT(ans)
INTERFACE
MODULE PURE FUNCTION matmul_r4_r2(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
- REAL(DFP), INTENT(IN) :: a2(:,:)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3), size(a2, 2))
+ REAL(DFP), INTENT(IN) :: a2(:, :)
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3), SIZE(a2, 2))
END FUNCTION
END INTERFACE
@@ -70,6 +96,23 @@ MODULE PURE FUNCTION matmul_r4_r2(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r4_r2
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r4_r2_(a1, a2, ans, dim1, dim2, dim3, dim4)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE matmul_r4_r2_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r4_r2_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -85,9 +128,9 @@ MODULE PURE FUNCTION matmul_r4_r2(a1, a2) RESULT(ans)
INTERFACE
MODULE PURE FUNCTION matmul_r4_r3(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
- REAL(DFP), INTENT(IN) :: a2(:,:,:)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3), &
- & size(a2, 2), size(a2, 3))
+ REAL(DFP), INTENT(IN) :: a2(:, :, :)
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3), &
+ & SIZE(a2, 2), SIZE(a2, 3))
END FUNCTION
END INTERFACE
@@ -95,6 +138,24 @@ MODULE PURE FUNCTION matmul_r4_r3(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r4_r3
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r4_r3_(a1, a2, ans, dim1, dim2, dim3, dim4, &
+ dim5)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4, dim5
+ END SUBROUTINE matmul_r4_r3_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r4_r3_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -110,9 +171,9 @@ MODULE PURE FUNCTION matmul_r4_r3(a1, a2) RESULT(ans)
INTERFACE
MODULE PURE FUNCTION matmul_r4_r4(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
- REAL(DFP), INTENT(IN) :: a2(:,:,:,:)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), size(a1, 3), &
- & size(a2, 2), size(a2, 3), size(a2, 4))
+ REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), SIZE(a1, 3), &
+ & SIZE(a2, 2), SIZE(a2, 3), SIZE(a2, 4))
END FUNCTION
END INTERFACE
@@ -120,6 +181,24 @@ MODULE PURE FUNCTION matmul_r4_r4(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r4_r4
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r4_r4_(a1, a2, ans, dim1, dim2, dim3, &
+ dim4, dim5, dim6)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4, dim5, dim6
+ END SUBROUTINE matmul_r4_r4_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r4_r4_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -137,7 +216,7 @@ MODULE PURE FUNCTION matmul_r4_r4(a1, a2) RESULT(ans)
MODULE PURE FUNCTION matmul_r3_r1(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :, :)
REAL(DFP), INTENT(IN) :: a2(:)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2))
END FUNCTION
END INTERFACE
@@ -145,6 +224,23 @@ MODULE PURE FUNCTION matmul_r3_r1(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r3_r1
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r3_r1_(a1, a2, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE matmul_r3_r1_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r3_r1_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -161,8 +257,8 @@ MODULE PURE FUNCTION matmul_r3_r1(a1, a2) RESULT(ans)
MODULE PURE FUNCTION matmul_r3_r2(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :, :)
REAL(DFP), INTENT(IN) :: a2(:, :)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), &
- & size(a2, 2))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), &
+ & SIZE(a2, 2))
END FUNCTION
END INTERFACE
@@ -170,6 +266,23 @@ MODULE PURE FUNCTION matmul_r3_r2(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r3_r2
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r3_r2_(a1, a2, ans, dim1, dim2, dim3)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matmul_r3_r2_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r3_r2_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -184,10 +297,10 @@ MODULE PURE FUNCTION matmul_r3_r2(a1, a2) RESULT(ans)
INTERFACE
MODULE PURE FUNCTION matmul_r3_r3(a1, a2) RESULT(ans)
- REAL(DFP), INTENT(IN) :: a1(:,:,:)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :)
REAL(DFP), INTENT(IN) :: a2(:, :, :)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), &
- & size(a2, 2), size(a2, 3))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), &
+ & SIZE(a2, 2), SIZE(a2, 3))
END FUNCTION
END INTERFACE
@@ -195,6 +308,24 @@ MODULE PURE FUNCTION matmul_r3_r3(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r3_r3
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r3_r3_(a1, a2, ans, dim1, dim2, dim3, &
+ dim4)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE matmul_r3_r3_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r3_r3_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -209,10 +340,10 @@ MODULE PURE FUNCTION matmul_r3_r3(a1, a2) RESULT(ans)
INTERFACE
MODULE PURE FUNCTION matmul_r3_r4(a1, a2) RESULT(ans)
- REAL(DFP), INTENT(IN) :: a1(:,:,:)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :)
REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
- REAL(DFP) :: ans(size(a1, 1), size(a1, 2), &
- & size(a2, 2), size(a2, 3), size(a2, 4))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a1, 2), &
+ & SIZE(a2, 2), SIZE(a2, 3), SIZE(a2, 4))
END FUNCTION
END INTERFACE
@@ -220,6 +351,24 @@ MODULE PURE FUNCTION matmul_r3_r4(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r3_r4
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r3_r4_(a1, a2, ans, dim1, dim2, dim3, &
+ dim4, dim5)
+ REAL(DFP), INTENT(IN) :: a1(:, :, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4, dim5
+ END SUBROUTINE matmul_r3_r4_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r3_r4_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -237,7 +386,7 @@ MODULE PURE FUNCTION matmul_r3_r4(a1, a2) RESULT(ans)
MODULE PURE FUNCTION matmul_r2_r3(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :)
REAL(DFP), INTENT(IN) :: a2(:, :, :)
- REAL(DFP) :: ans(size(a1, 1), size(a2, 2), size(a2, 3))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a2, 2), SIZE(a2, 3))
END FUNCTION
END INTERFACE
@@ -245,6 +394,23 @@ MODULE PURE FUNCTION matmul_r2_r3(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r2_r3
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r2_r3_(a1, a2, ans, dim1, dim2, dim3)
+ REAL(DFP), INTENT(IN) :: a1(:, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matmul_r2_r3_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r2_r3_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -262,8 +428,8 @@ MODULE PURE FUNCTION matmul_r2_r3(a1, a2) RESULT(ans)
MODULE PURE FUNCTION matmul_r2_r4(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:, :)
REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
- REAL(DFP) :: ans(size(a1, 1), size(a2, 2), &
- & size(a2, 3), size(a2, 4))
+ REAL(DFP) :: ans(SIZE(a1, 1), SIZE(a2, 2), &
+ & SIZE(a2, 3), SIZE(a2, 4))
END FUNCTION
END INTERFACE
@@ -271,6 +437,23 @@ MODULE PURE FUNCTION matmul_r2_r4(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r2_r4
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r2_r4_(a1, a2, ans, dim1, dim2, dim3, dim4)
+ REAL(DFP), INTENT(IN) :: a1(:, :)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE matmul_r2_r4_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r2_r4_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -296,6 +479,22 @@ MODULE PURE FUNCTION matmul_r1_r1(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r1_r1
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r1_r1_(a1, a2, ans)
+ REAL(DFP), INTENT(IN) :: a1(:)
+ REAL(DFP), INTENT(IN) :: a2(:)
+ REAL(DFP), INTENT(INOUT) :: ans
+ END SUBROUTINE matmul_r1_r1_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r1_r1_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
! Matmul@Matmul
!----------------------------------------------------------------------------
@@ -313,7 +512,7 @@ MODULE PURE FUNCTION matmul_r1_r1(a1, a2) RESULT(ans)
MODULE PURE FUNCTION matmul_r1_r3(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:)
REAL(DFP), INTENT(IN) :: a2(:, :, :)
- REAL(DFP) :: ans(size(a2, 2), size(a2, 3))
+ REAL(DFP) :: ans(SIZE(a2, 2), SIZE(a2, 3))
END FUNCTION
END INTERFACE
@@ -322,7 +521,24 @@ MODULE PURE FUNCTION matmul_r1_r3(a1, a2) RESULT(ans)
END INTERFACE MATMUL
!----------------------------------------------------------------------------
-! Matmul@Matmul
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r1_r3_(a1, a2, ans, nrow, ncol)
+ REAL(DFP), INTENT(IN) :: a1(:)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ END SUBROUTINE matmul_r1_r3_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r1_r3_
+END INTERFACE MATMUL_
+
+!----------------------------------------------------------------------------
+! Matmul
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -337,7 +553,7 @@ MODULE PURE FUNCTION matmul_r1_r3(a1, a2) RESULT(ans)
MODULE PURE FUNCTION matmul_r1_r4(a1, a2) RESULT(ans)
REAL(DFP), INTENT(IN) :: a1(:)
REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
- REAL(DFP) :: ans(size(a2, 2), size(a2, 3), size(a2, 4))
+ REAL(DFP) :: ans(SIZE(a2, 2), SIZE(a2, 3), SIZE(a2, 4))
END FUNCTION
END INTERFACE
@@ -345,8 +561,26 @@ MODULE PURE FUNCTION matmul_r1_r4(a1, a2) RESULT(ans)
MODULE PROCEDURE matmul_r1_r4
END INTERFACE MATMUL
+!----------------------------------------------------------------------------
+! Matmul_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ MODULE PURE SUBROUTINE matmul_r1_r4_(a1, a2, ans, dim1, dim2, dim3)
+ REAL(DFP), INTENT(IN) :: a1(:)
+ REAL(DFP), INTENT(IN) :: a2(:, :, :, :)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ END SUBROUTINE matmul_r1_r4_
+END INTERFACE
+
+INTERFACE MATMUL_
+ MODULE PROCEDURE matmul_r1_r4_
+END INTERFACE MATMUL_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-END MODULE MatmulUtility
\ No newline at end of file
+END MODULE MatmulUtility
+
diff --git a/src/modules/Utility/src/MiscUtility.F90 b/src/modules/Utility/src/MiscUtility.F90
index b50d156f3..0adca15e7 100644
--- a/src/modules/Utility/src/MiscUtility.F90
+++ b/src/modules/Utility/src/MiscUtility.F90
@@ -33,6 +33,9 @@ MODULE MiscUtility
PUBLIC :: IMAXLOC
PUBLIC :: IMINLOC
PUBLIC :: IMG
+PUBLIC :: LOC_NearestPoint
+PUBLIC :: safe_ACOS
+PUBLIC :: safe_ASIN
!----------------------------------------------------------------------------
! Radian@MISC
@@ -126,8 +129,6 @@ MODULE FUNCTION Loc_Nearest_Point(Array, x) RESULT(id)
MODULE PROCEDURE Loc_Nearest_Point
END INTERFACE LOC_NearestPoint
-PUBLIC :: LOC_NearestPoint
-
INTERFACE SearchNearestCoord
MODULE PROCEDURE Loc_Nearest_Point
END INTERFACE SearchNearestCoord
@@ -254,21 +255,21 @@ MODULE PURE FUNCTION arth_i(first, increment, n)
INTERFACE
MODULE PURE FUNCTION outerdiff_r(a, b)
REAL(SP), DIMENSION(:), INTENT(IN) :: a, b
- REAL(SP), DIMENSION(size(a), size(b)) :: outerdiff_r
+ REAL(SP), DIMENSION(SIZE(a), SIZE(b)) :: outerdiff_r
END FUNCTION
END INTERFACE
INTERFACE
MODULE PURE FUNCTION outerdiff_d(a, b)
REAL(DP), DIMENSION(:), INTENT(IN) :: a, b
- REAL(DP), DIMENSION(size(a), size(b)) :: outerdiff_d
+ REAL(DP), DIMENSION(SIZE(a), SIZE(b)) :: outerdiff_d
END FUNCTION
END INTERFACE
INTERFACE
MODULE PURE FUNCTION outerdiff_i(a, b)
INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a, b
- INTEGER(I4B), DIMENSION(size(a), size(b)) :: outerdiff_i
+ INTEGER(I4B), DIMENSION(SIZE(a), SIZE(b)) :: outerdiff_i
END FUNCTION
END INTERFACE
@@ -323,8 +324,8 @@ MODULE FUNCTION iminloc_r(arr)
INTERFACE
MODULE ELEMENTAL FUNCTION IMG_1(x) RESULT(ans)
- COMPLEX(Real32), INTENT(IN) :: x
- REAL(Real32) :: ans
+ COMPLEX(REAL32), INTENT(IN) :: x
+ REAL(REAL32) :: ans
END FUNCTION IMG_1
END INTERFACE
@@ -342,8 +343,8 @@ END FUNCTION IMG_1
INTERFACE
MODULE ELEMENTAL FUNCTION IMG_2(x) RESULT(ans)
- COMPLEX(Real64), INTENT(IN) :: x
- REAL(Real64) :: ans
+ COMPLEX(REAL64), INTENT(IN) :: x
+ REAL(REAL64) :: ans
END FUNCTION IMG_2
END INTERFACE
@@ -362,8 +363,6 @@ MODULE ELEMENTAL FUNCTION safe_ACOS(c) RESULT(ans)
END FUNCTION safe_ACOS
END INTERFACE
-PUBLIC :: safe_ACOS
-
!----------------------------------------------------------------------------
! safe_ASIN
!----------------------------------------------------------------------------
@@ -375,8 +374,6 @@ MODULE ELEMENTAL FUNCTION safe_ASIN(s) RESULT(ans)
END FUNCTION safe_ASIN
END INTERFACE
-PUBLIC :: safe_ASIN
-
!----------------------------------------------------------------------------
! Factorial@MISC
!----------------------------------------------------------------------------
diff --git a/src/modules/Utility/src/ProductUtility.F90 b/src/modules/Utility/src/ProductUtility.F90
index 8bbe18966..1e0d9269c 100644
--- a/src/modules/Utility/src/ProductUtility.F90
+++ b/src/modules/Utility/src/ProductUtility.F90
@@ -16,16 +16,110 @@
!
MODULE ProductUtility
-USE GlobalData
+USE GlobalData, ONLY: DFP, REAL32, REAL64, LGT, I4B
+
IMPLICIT NONE
+
PRIVATE
-PUBLIC :: OUTERPROD
+
+PUBLIC :: OuterProd
+PUBLIC :: OuterProd_
+PUBLIC :: OTimesTilda
+PUBLIC :: OTimesTilda_
PUBLIC :: Cross_Product
PUBLIC :: Vector_Product
PUBLIC :: VectorProduct
!----------------------------------------------------------------------------
-! Cross_Product@ProductMethods
+! OTimesTilda
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-13
+! summary: returns a space-time matrix from time and space matrix
+
+INTERFACE
+ MODULE PURE SUBROUTINE OTimesTilda1(a, b, ans, nrow, ncol, anscoeff, scale)
+ REAL(DFP), INTENT(IN) :: a(:, :)
+ !! time matrix
+ REAL(DFP), INTENT(IN) :: b(:, :)
+ !! space matrix
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! space time matix in DOF Format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: anscoeff
+ REAL(DFP), INTENT(IN) :: scale
+ END SUBROUTINE OTimesTilda1
+END INTERFACE
+
+INTERFACE OTimesTilda
+ MODULE PROCEDURE OTimesTilda1
+END INTERFACE OTimesTilda
+
+INTERFACE OTimesTilda_
+ MODULE PROCEDURE OTimesTilda1
+END INTERFACE OTimesTilda_
+
+!----------------------------------------------------------------------------
+! OtimesTilda
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-13
+! summary: returns a space-time vector from time and space vector
+
+INTERFACE
+ MODULE PURE 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
+
+INTERFACE OTimesTilda
+ MODULE PROCEDURE OTimesTilda2
+END INTERFACE OTimesTilda
+
+INTERFACE OTimesTilda_
+ MODULE PROCEDURE OTimesTilda2
+END INTERFACE OTimesTilda_
+
+!----------------------------------------------------------------------------
+! OTimesTilda
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2024-08-13
+! summary: returns a space-time matrix from time and space matrix
+
+INTERFACE
+ MODULE PURE SUBROUTINE OTimesTilda3(a, b, c, d, ans, nrow, ncol, &
+ anscoeff, scale)
+ REAL(DFP), INTENT(IN) :: a(:), b(:)
+ !! time matrix
+ REAL(DFP), INTENT(IN) :: c(:), d(:)
+ !! space matrix
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! space time matix in DOF Format
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+ REAL(DFP), INTENT(IN) :: anscoeff
+ REAL(DFP), INTENT(IN) :: scale
+ END SUBROUTINE OTimesTilda3
+END INTERFACE
+
+INTERFACE OTimesTilda
+ MODULE PROCEDURE OTimesTilda3
+END INTERFACE OTimesTilda
+
+INTERFACE OTimesTilda_
+ MODULE PROCEDURE OTimesTilda3
+END INTERFACE OTimesTilda_
+
+!----------------------------------------------------------------------------
+! Cross_Product
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -52,70 +146,115 @@ MODULE PURE FUNCTION vectorProduct_2(a, b) RESULT(c)
END FUNCTION vectorProduct_2
END INTERFACE
-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 Cross_Product
+ MODULE PROCEDURE vectorProduct_1, vectorProduct_2
+END INTERFACE Cross_Product
+
INTERFACE VectorProduct
MODULE PROCEDURE vectorProduct_1, vectorProduct_2
END INTERFACE VectorProduct
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 22 March 2021
-! summary: This FUNCTION returns outerproduct(matrix) of two vectors
+! date: 22 March 2021
+! 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)
+ 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 FUNCTION OuterProd_r1r1
+END INTERFACE
+
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1
+END INTERFACE OuterProd
+
+!----------------------------------------------------------------------------
+! OuterProd_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r1r1_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> 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)
+ 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
+ LOGICAL(LGT), INTENT(IN) :: sym
+ END FUNCTION OuterProd_r1r1s
+END INTERFACE
+
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1s
+END INTERFACE OuterProd
+
+!----------------------------------------------------------------------------
+! OuterProd_
+!----------------------------------------------------------------------------
+
+INTERFACE
+ 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
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1s
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r1r1s_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -124,19 +263,42 @@ END FUNCTION outerprod_r1r1s
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2(a, b) RESULT(ans)
+ 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 FUNCTION OuterProd_r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd_
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2025-03-05
+! summary: a x b
+
+INTERFACE
+ 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
+
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r1r2_
+END INTERFACE OuterProd_
+
+!----------------------------------------------------------------------------
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -145,19 +307,19 @@ END FUNCTION outerprod_r1r2
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3(a, b) RESULT(ans)
+ 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 FUNCTION OuterProd_r1r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -166,19 +328,19 @@ END FUNCTION outerprod_r1r3
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r4(a, b) RESULT(ans)
+ 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 FUNCTION OuterProd_r1r4
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r4
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r4
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -187,45 +349,84 @@ END FUNCTION outerprod_r1r4
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r5(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r1r5(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),&
- & SIZE(b, 5))
- END FUNCTION outerprod_r1r5
+ REAL(DFP) :: ans(SIZE(a), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), &
+ SIZE(b, 4), SIZE(b, 5))
+ END FUNCTION OuterProd_r1r5
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r5
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r5
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> 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)
+ 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 FUNCTION OuterProd_r2r1
+END INTERFACE
+
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1
+END INTERFACE OuterProd
+
+!----------------------------------------------------------------------------
+! OuterProd_
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-09-04
+! summary: a x b
+
+INTERFACE
+ MODULE PURE SUBROUTINE OuterProd_r2r1_(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_r2r1_
+END INTERFACE
+
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r2r1_
+END INTERFACE OuterProd_
+
+!----------------------------------------------------------------------------
+! OuterProd
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-19
+! update: 2021-12-19
+! summary: a x b
+
+INTERFACE
+ MODULE PURE FUNCTION OuterProd_r2r2(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, 1), SIZE(b, 2))
+ END FUNCTION OuterProd_r2r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd_
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -234,23 +435,22 @@ END FUNCTION outerprod_r2r1
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2(a, b) RESULT(ans)
+ MODULE PURE SUBROUTINE OuterProd_r2r2_(a, b, ans, dim1, dim2, dim3, dim4, &
+ anscoeff, scale)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(b, 2))
- END FUNCTION outerprod_r2r2
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ REAL(DFP), INTENT(IN) :: anscoeff, scale
+ END SUBROUTINE OuterProd_r2r2_
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r2r2_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -259,24 +459,20 @@ END FUNCTION outerprod_r2r2
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r3(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r2r3(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, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3))
- END FUNCTION outerprod_r2r3
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), &
+ SIZE(b, 3))
+ END FUNCTION OuterProd_r2r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -285,25 +481,20 @@ END FUNCTION outerprod_r2r3
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r4(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r2r4(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, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3),&
- & SIZE(b, 4))
- END FUNCTION outerprod_r2r4
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), &
+ SIZE(b, 3), SIZE(b, 4))
+ END FUNCTION OuterProd_r2r4
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r4
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r4
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -312,23 +503,19 @@ END FUNCTION outerprod_r2r4
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r3r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:)
- REAL(DFP) :: ans(&
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b))
- END FUNCTION outerprod_r3r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b))
+ END FUNCTION OuterProd_r3r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -337,24 +524,20 @@ END FUNCTION outerprod_r3r1
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r2(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r3r2(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:, :)
- REAL(DFP) :: ans(&
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b, 1),&
- & SIZE(b, 2))
- END FUNCTION outerprod_r3r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), &
+ SIZE(b, 2))
+ END FUNCTION OuterProd_r3r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -363,25 +546,20 @@ END FUNCTION outerprod_r3r2
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r3(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r3r3(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :)
REAL(DFP), INTENT(IN) :: b(:, :, :)
- REAL(DFP) :: ans(&
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3))
- END FUNCTION outerprod_r3r3
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), &
+ SIZE(b, 2), SIZE(b, 3))
+ END FUNCTION OuterProd_r3r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -390,24 +568,20 @@ END FUNCTION outerprod_r3r3
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r4r1(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r4r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :)
REAL(DFP), INTENT(IN) :: b(:)
- REAL(DFP) :: ans(&
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(a, 4),&
- & SIZE(b, 1))
- END FUNCTION outerprod_r4r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), &
+ SIZE(b, 1))
+ END FUNCTION OuterProd_r4r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r4r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r4r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -416,25 +590,20 @@ END FUNCTION outerprod_r4r1
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r4r2(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r4r2(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :)
REAL(DFP), INTENT(IN) :: b(:, :)
- REAL(DFP) :: ans(&
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(a, 4),&
- & SIZE(b, 1),&
- & SIZE(b, 2))
- END FUNCTION outerprod_r4r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), &
+ SIZE(b, 1), SIZE(b, 2))
+ END FUNCTION OuterProd_r4r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r4r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r4r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@ProductMethods
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -443,25 +612,42 @@ END FUNCTION outerprod_r4r2
! summary: a x b
INTERFACE
- MODULE PURE FUNCTION outerprod_r5r1(a, b) RESULT(ans)
+ MODULE PURE FUNCTION OuterProd_r5r1(a, b) RESULT(ans)
REAL(DFP), INTENT(IN) :: a(:, :, :, :, :)
REAL(DFP), INTENT(IN) :: b(:)
- REAL(DFP) :: ans(&
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(a, 4),&
- & SIZE(a, 5),&
- & SIZE(b, 1))
- END FUNCTION outerprod_r5r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), &
+ SIZE(a, 5), SIZE(b, 1))
+ END FUNCTION OuterProd_r5r1
+END INTERFACE
+
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r5r1
+END INTERFACE OuterProd
+
+!----------------------------------------------------------------------------
+! OuterProd
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-19
+! update: 2021-12-19
+! summary: a b c
+
+INTERFACE
+ 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(:)
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1))
+ END FUNCTION OuterProd_r1r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r5r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -470,23 +656,45 @@ END FUNCTION outerprod_r5r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1(a, b, c) RESULT(ans)
+ MODULE PURE SUBROUTINE OuterProd_r1r1r1_( &
+ a, b, c, anscoeff, scale, ans, dim1, dim2, dim3)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r1r1r1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ REAL(DFP), INTENT(IN) :: anscoeff, scale
+ END SUBROUTINE OuterProd_r1r1r1_
+END INTERFACE
+
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r1r1r1_
+END INTERFACE OuterProd_
+
+!----------------------------------------------------------------------------
+! OuterProd
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-19
+! update: 2021-12-19
+! summary: a b c
+
+INTERFACE
+ 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(:, :)
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2))
+ END FUNCTION OuterProd_r1r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd_
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -495,24 +703,23 @@ END FUNCTION outerprod_r1r1r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r2(a, b, c) RESULT(ans)
+ MODULE PURE SUBROUTINE OuterProd_r1r1r2_( &
+ a, b, c, anscoeff, scale, ans, dim1, dim2, dim3, dim4)
REAL(DFP), INTENT(IN) :: a(:)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2))
- END FUNCTION outerprod_r1r1r2
+ REAL(DFP), INTENT(IN) :: anscoeff, scale
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ END SUBROUTINE OuterProd_r1r1r2_
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r1r1r2_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -521,25 +728,21 @@ END FUNCTION outerprod_r1r1r2
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r3(a, b, c) RESULT(ans)
+ 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(:, :, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(c, 3))
- END FUNCTION outerprod_r1r1r3
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), &
+ SIZE(c, 3))
+ END FUNCTION OuterProd_r1r1r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -548,26 +751,21 @@ END FUNCTION outerprod_r1r1r3
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r4(a, b, c) RESULT(ans)
+ 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(:, :, :, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(c, 3),&
- & SIZE(c, 4))
- END FUNCTION outerprod_r1r1r4
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), &
+ SIZE(c, 3), SIZE(c, 4))
+ END FUNCTION OuterProd_r1r1r4
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r4
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r4
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -576,24 +774,20 @@ END FUNCTION outerprod_r1r1r4
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r1r2r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1))
+ END FUNCTION OuterProd_r1r2r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -602,25 +796,21 @@ END FUNCTION outerprod_r1r2r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r2(a, b, c) RESULT(ans)
+ 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(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(c, 2))
- END FUNCTION outerprod_r1r2r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), &
+ SIZE(c, 2))
+ END FUNCTION OuterProd_r1r2r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -629,26 +819,21 @@ END FUNCTION outerprod_r1r2r2
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r3(a, b, c) RESULT(ans)
+ 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(:, :, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(c, 3))
- END FUNCTION outerprod_r1r2r3
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), &
+ SIZE(c, 2), SIZE(c, 3))
+ END FUNCTION OuterProd_r1r2r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -657,25 +842,21 @@ END FUNCTION outerprod_r1r2r3
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r1r3r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), &
+ SIZE(c, 1))
+ END FUNCTION OuterProd_r1r3r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r3r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -684,26 +865,21 @@ END FUNCTION outerprod_r1r3r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3r2(a, b, c) RESULT(ans)
+ 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(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3),&
- & SIZE(c, 1),&
- & SIZE(c, 2))
- END FUNCTION outerprod_r1r3r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), &
+ SIZE(c, 1), SIZE(c, 2))
+ END FUNCTION OuterProd_r1r3r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r3r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -712,26 +888,43 @@ END FUNCTION outerprod_r1r3r2
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r4r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3),&
- & SIZE(b, 4),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r1r4r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), &
+ SIZE(b, 4), SIZE(c, 1))
+ END FUNCTION OuterProd_r1r4r1
+END INTERFACE
+
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r4r1
+END INTERFACE OuterProd
+
+!----------------------------------------------------------------------------
+! OuterProd
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-12-19
+! update: 2021-12-19
+! summary: a b c
+
+INTERFACE
+ 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(:)
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1))
+ END FUNCTION OuterProd_r2r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r4r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd_
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -740,24 +933,23 @@ END FUNCTION outerprod_r1r4r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r1(a, b, c) RESULT(ans)
+ MODULE PURE SUBROUTINE OuterProd_r2r1r1_(a, b, c, ans, dim1, dim2, dim3, &
+ dim4, scale, anscoeff)
REAL(DFP), INTENT(IN) :: a(:, :)
REAL(DFP), INTENT(IN) :: b(:)
REAL(DFP), INTENT(IN) :: c(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r2r1r1
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+ REAL(DFP), INTENT(IN) :: scale, anscoeff
+ END SUBROUTINE OuterProd_r2r1r1_
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd_
+ MODULE PROCEDURE OuterProd_r2r1r1_
+END INTERFACE OuterProd_
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -766,25 +958,21 @@ END FUNCTION outerprod_r2r1r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r2(a, b, c) RESULT(ans)
+ 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(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2))
- END FUNCTION outerprod_r2r1r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), &
+ SIZE(c, 2))
+ END FUNCTION OuterProd_r2r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -793,26 +981,21 @@ END FUNCTION outerprod_r2r1r2
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r3(a, b, c) RESULT(ans)
+ 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(:, :, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(c, 3))
- END FUNCTION outerprod_r2r1r3
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), &
+ SIZE(c, 2), SIZE(c, 3))
+ END FUNCTION OuterProd_r2r1r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -821,25 +1004,21 @@ END FUNCTION outerprod_r2r1r3
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r2r2r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), &
+ SIZE(c, 1))
+ END FUNCTION OuterProd_r2r2r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -848,26 +1027,21 @@ END FUNCTION outerprod_r2r2r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2r2(a, b, c) RESULT(ans)
+ 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(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(c, 2))
- END FUNCTION outerprod_r2r2r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), &
+ SIZE(c, 1), SIZE(c, 2))
+ END FUNCTION OuterProd_r2r2r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -876,25 +1050,21 @@ END FUNCTION outerprod_r2r2r2
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b, 1),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r3r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), &
+ SIZE(c, 1))
+ END FUNCTION OuterProd_r3r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -903,26 +1073,21 @@ END FUNCTION outerprod_r3r1r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1r2(a, b, c) RESULT(ans)
+ 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(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2))
- END FUNCTION outerprod_r3r1r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), &
+ SIZE(c, 1), SIZE(c, 2))
+ END FUNCTION OuterProd_r3r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -931,26 +1096,21 @@ END FUNCTION outerprod_r3r1r2
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r2r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r3r2r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), &
+ SIZE(b, 2), SIZE(c, 1))
+ END FUNCTION OuterProd_r3r2r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -959,26 +1119,21 @@ END FUNCTION outerprod_r3r2r1
! summary: a b c
INTERFACE
- MODULE PURE FUNCTION outerprod_r4r1r1(a, b, c) RESULT(ans)
+ 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(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(a, 4),&
- & SIZE(b, 1),&
- & SIZE(c, 1))
- END FUNCTION outerprod_r4r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(a, 4), &
+ SIZE(b, 1), SIZE(c, 1))
+ END FUNCTION OuterProd_r4r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r4r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r4r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -987,25 +1142,21 @@ END FUNCTION outerprod_r4r1r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1r1(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r1r1r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(d, 1))
+ END FUNCTION OuterProd_r1r1r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1014,26 +1165,22 @@ END FUNCTION outerprod_r1r1r1r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1r2(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(d, 1),&
- & SIZE(d, 2))
- END FUNCTION outerprod_r1r1r1r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(d, 1), &
+ SIZE(d, 2))
+ END FUNCTION OuterProd_r1r1r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1042,27 +1189,22 @@ END FUNCTION outerprod_r1r1r1r2
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r1r3(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:, :, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(d, 1),&
- & SIZE(d, 2),&
- & SIZE(d, 3))
- END FUNCTION outerprod_r1r1r1r3
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(d, 1), &
+ SIZE(d, 2), SIZE(d, 3))
+ END FUNCTION OuterProd_r1r1r1r3
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r1r3
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r1r3
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1071,26 +1213,22 @@ END FUNCTION outerprod_r1r1r1r3
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r2r1(a, b, c, d) RESULT(ans)
+ 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(:, :)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r1r1r2r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), &
+ SIZE(d, 1))
+ END FUNCTION OuterProd_r1r1r2r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1099,27 +1237,22 @@ END FUNCTION outerprod_r1r1r2r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r2r2(a, b, c, d) RESULT(ans)
+ 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(:, :)
REAL(DFP), INTENT(IN) :: d(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(d, 1),&
- & SIZE(d, 2))
- END FUNCTION outerprod_r1r1r2r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), &
+ SIZE(d, 1), SIZE(d, 2))
+ END FUNCTION OuterProd_r1r1r2r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r2r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r2r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1128,27 +1261,22 @@ END FUNCTION outerprod_r1r1r2r2
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r1r3r1(a, b, c, d) RESULT(ans)
+ 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(:, :, :)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(c, 3),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r1r1r3r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(c, 1), SIZE(c, 2), &
+ SIZE(c, 3), SIZE(d, 1))
+ END FUNCTION OuterProd_r1r1r3r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r1r3r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r1r3r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1157,26 +1285,22 @@ END FUNCTION outerprod_r1r1r3r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r1r1(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r1r2r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), &
+ SIZE(d, 1))
+ END FUNCTION OuterProd_r1r2r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1185,27 +1309,22 @@ END FUNCTION outerprod_r1r2r1r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r1r2(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(d, 1),&
- & SIZE(d, 2))
- END FUNCTION outerprod_r1r2r1r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), &
+ SIZE(d, 1), SIZE(d, 2))
+ END FUNCTION OuterProd_r1r2r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1214,27 +1333,22 @@ END FUNCTION outerprod_r1r2r1r2
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r2r2r1(a, b, c, d) RESULT(ans)
+ 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(:, :)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r1r2r2r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(c, 1), &
+ SIZE(c, 2), SIZE(d, 1))
+ END FUNCTION OuterProd_r1r2r2r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r2r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r2r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1243,27 +1357,22 @@ END FUNCTION outerprod_r1r2r2r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r1r3r1r1(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(b, 3),&
- & SIZE(c, 1),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r1r3r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(b, 1), SIZE(b, 2), SIZE(b, 3), &
+ SIZE(c, 1), SIZE(d, 1))
+ END FUNCTION OuterProd_r1r3r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r1r3r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r1r3r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1272,26 +1381,22 @@ END FUNCTION outerprod_r1r3r1r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r1r1(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r2r1r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), &
+ SIZE(d, 1))
+ END FUNCTION OuterProd_r2r1r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1300,27 +1405,22 @@ END FUNCTION outerprod_r2r1r1r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r1r2(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:, :)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(d, 1),&
- & SIZE(d, 2))
- END FUNCTION outerprod_r2r1r1r2
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), &
+ SIZE(d, 1), SIZE(d, 2))
+ END FUNCTION OuterProd_r2r1r1r2
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r1r2
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1r1r2
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1329,27 +1429,22 @@ END FUNCTION outerprod_r2r1r1r2
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r1r2r1(a, b, c, d) RESULT(ans)
+ 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(:, :)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(c, 2),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r2r1r2r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(c, 1), &
+ SIZE(c, 2), SIZE(d, 1))
+ END FUNCTION OuterProd_r2r1r2r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r1r2r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r1r2r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1358,27 +1453,22 @@ END FUNCTION outerprod_r2r1r2r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r2r2r1r1(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(b, 1),&
- & SIZE(b, 2),&
- & SIZE(c, 1),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r2r2r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(b, 1), SIZE(b, 2), &
+ SIZE(c, 1), SIZE(d, 1))
+ END FUNCTION OuterProd_r2r2r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r2r2r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r2r2r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
-! OUTERPROD@PROD
+! OuterProd
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -1387,24 +1477,19 @@ END FUNCTION outerprod_r2r2r1r1
! summary: a b c d
INTERFACE
- MODULE PURE FUNCTION outerprod_r3r1r1r1(a, b, c, d) RESULT(ans)
+ 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(:)
REAL(DFP), INTENT(IN) :: d(:)
- REAL(DFP) :: ans( &
- & SIZE(a, 1),&
- & SIZE(a, 2),&
- & SIZE(a, 3),&
- & SIZE(b, 1),&
- & SIZE(c, 1),&
- & SIZE(d, 1))
- END FUNCTION outerprod_r3r1r1r1
+ REAL(DFP) :: ans(SIZE(a, 1), SIZE(a, 2), SIZE(a, 3), SIZE(b, 1), &
+ SIZE(c, 1), SIZE(d, 1))
+ END FUNCTION OuterProd_r3r1r1r1
END INTERFACE
-INTERFACE OUTERPROD
- MODULE PROCEDURE outerprod_r3r1r1r1
-END INTERFACE OUTERPROD
+INTERFACE OuterProd
+ MODULE PROCEDURE OuterProd_r3r1r1r1
+END INTERFACE OuterProd
!----------------------------------------------------------------------------
!
diff --git a/src/modules/Utility/src/ReallocateUtility.F90 b/src/modules/Utility/src/ReallocateUtility.F90
index 132063cdf..08bcb9b63 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,15 @@ 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 +128,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 +144,15 @@ 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 +161,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 +177,15 @@ 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 +194,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 +210,15 @@ 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 +227,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 +243,15 @@ 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 +260,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 +276,15 @@ 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 +293,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 +309,15 @@ 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 +326,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 +342,15 @@ 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 +359,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 +375,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 +392,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 +408,15 @@ 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 +425,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 +441,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 +458,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 +474,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 +491,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 +507,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 +523,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 +543,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 +559,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 +575,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 +591,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 +607,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 +623,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 +639,88 @@ 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 +729,15 @@ 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 +746,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 +762,15 @@ 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 +779,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 +795,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 +812,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 +828,15 @@ 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 +845,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 +861,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 +878,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 +894,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 +911,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 +927,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 +944,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 +960,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 +977,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 +993,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 +1010,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 +1026,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 +1043,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 +1059,19 @@ 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 +1080,20 @@ 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 +1102,20 @@ 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 +1124,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 +1142,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 +1160,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 +1178,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/ReverseUtility.F90 b/src/modules/Utility/src/ReverseUtility.F90
new file mode 100644
index 000000000..2390c37af
--- /dev/null
+++ b/src/modules/Utility/src/ReverseUtility.F90
@@ -0,0 +1,255 @@
+! 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 ReverseUtility
+USE GlobalData, ONLY: I4B, DFP, LGT, REAL32, REAL64, INT8, INT16, INT32, &
+ INT64
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of an integer array
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int8_R1(ans, n1, n2)
+ INTEGER(INT8), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(IN) :: n1, n2
+ END SUBROUTINE Reverse_Int8_R1
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of an integer array
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int16_R1(ans, n1, n2)
+ INTEGER(INT16), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(IN) :: n1, n2
+ END SUBROUTINE Reverse_Int16_R1
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of an integer array
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int32_R1(ans, n1, n2)
+ INTEGER(INT32), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(IN) :: n1, n2
+ END SUBROUTINE Reverse_Int32_R1
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of an integer array
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int64_R1(ans, n1, n2)
+ INTEGER(INT64), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(IN) :: n1, n2
+ END SUBROUTINE Reverse_Int64_R1
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a real array
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Real32_R1(ans, n1, n2)
+ REAL(REAL32), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(IN) :: n1, n2
+ END SUBROUTINE Reverse_Real32_R1
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a real array
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Real64_R1(ans, n1, n2)
+ REAL(REAL64), INTENT(INOUT) :: ans(:)
+ INTEGER(I4B), INTENT(IN) :: n1, n2
+ END SUBROUTINE Reverse_Real64_R1
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a integer matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int8_R2(ans, r1, r2, c1, c2, dim)
+ INTEGER(INT8), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2
+ !! Extent of ans(r1:r2, c1:c2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the rows
+ !! dim=2, reverse the columns
+ END SUBROUTINE Reverse_Int8_R2
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a integer matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int16_R2(ans, r1, r2, c1, c2, dim)
+ INTEGER(INT16), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2
+ !! Extent of ans(r1:r2, c1:c2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the rows
+ !! dim=2, reverse the columns
+ END SUBROUTINE Reverse_Int16_R2
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a integer matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int32_R2(ans, r1, r2, c1, c2, dim)
+ INTEGER(INT32), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2
+ !! Extent of ans(r1:r2, c1:c2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the rows
+ !! dim=2, reverse the columns
+ END SUBROUTINE Reverse_Int32_R2
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a integer matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Int64_R2(ans, r1, r2, c1, c2, dim)
+ INTEGER(INT64), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2
+ !! Extent of ans(r1:r2, c1:c2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the rows
+ !! dim=2, reverse the columns
+ END SUBROUTINE Reverse_Int64_R2
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a real matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Real32_R2(ans, r1, r2, c1, c2, dim)
+ REAL(REAL32), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2
+ !! Extent of ans(r1:r2, c1:c2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the rows
+ !! dim=2, reverse the columns
+ END SUBROUTINE Reverse_Real32_R2
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a real matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Real64_R2(ans, r1, r2, c1, c2, dim)
+ REAL(REAL64), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2
+ !! Extent of ans(r1:r2, c1:c2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the rows
+ !! dim=2, reverse the columns
+ END SUBROUTINE Reverse_Real64_R2
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+! Reverse@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: This function reverses the elements of a real matrix
+
+INTERFACE Reverse
+ MODULE SUBROUTINE Reverse_Real64_R3(ans, r1, r2, c1, c2, d1, d2, dim)
+ REAL(REAL64), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(IN) :: r1, r2, c1, c2, d1, d2
+ !! Extent of ans(r1:r2, c1:c2, d1:d2)
+ INTEGER(I4B), INTENT(IN) :: dim
+ !! dim=1, reverse the dim1
+ !! dim=2, reverse the dim2
+ !! dim=3, reverse the dim3
+ END SUBROUTINE Reverse_Real64_R3
+END INTERFACE Reverse
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE ReverseUtility
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 043932b6c..3b83c1246 100644
--- a/src/modules/Utility/src/SwapUtility.F90
+++ b/src/modules/Utility/src/SwapUtility.F90
@@ -16,13 +16,22 @@
!
MODULE SwapUtility
-USE GlobalData
+USE GlobalData, ONLY: INT8, INT16, INT32, INT64, REAL32, REAL64, &
+ DFPC, LGT, I4B
+
+#ifdef USE_BLAS95
+USE F95_BLAS, ONLY: SWAP
+#endif
+
IMPLICIT NONE
+
PRIVATE
+
PUBLIC :: Swap
+PUBLIC :: Swap_
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -33,19 +42,52 @@ MODULE SwapUtility
MODULE PURE SUBROUTINE Swap_Int8(a, b)
INTEGER(INT8), INTENT(INOUT) :: a, b
END SUBROUTINE Swap_Int8
+END INTERFACE swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two integer
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int16(a, b)
INTEGER(INT16), INTENT(INOUT) :: a, b
END SUBROUTINE Swap_Int16
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two integer
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int32(a, b)
INTEGER(INT32), INTENT(INOUT) :: a, b
END SUBROUTINE Swap_Int32
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two integer
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int64(a, b)
INTEGER(INT64), INTENT(INOUT) :: a, b
END SUBROUTINE Swap_Int64
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -59,7 +101,7 @@ END SUBROUTINE Swap_r32
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -73,7 +115,7 @@ END SUBROUTINE Swap_r64
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -85,7 +127,19 @@ END SUBROUTINE Swap_r64
MODULE PURE SUBROUTINE Swap_r32v(a, b)
REAL(REAL32), INTENT(INOUT) :: a(:), b(:)
END SUBROUTINE Swap_r32v
+END INTERFACE Swap
+#endif
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two vectors of real, if blas95 is used then ignore it.
+#ifndef USE_BLAS95
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_r64v(a, b)
REAL(REAL64), INTENT(INOUT) :: a(:), b(:)
END SUBROUTINE Swap_r64v
@@ -93,7 +147,7 @@ END SUBROUTINE Swap_r64v
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -104,21 +158,58 @@ END SUBROUTINE Swap_r64v
MODULE PURE SUBROUTINE Swap_Int8v(a, b)
INTEGER(INT8), INTENT(INOUT) :: a(:), b(:)
END SUBROUTINE Swap_Int8v
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two vectors of real, if blas95 is used then ignore it.
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int16v(a, b)
INTEGER(INT16), INTENT(INOUT) :: a(:), b(:)
END SUBROUTINE Swap_Int16v
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two vectors of real, if blas95 is used then ignore it.
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int32v(a, b)
INTEGER(INT32), INTENT(INOUT) :: a(:), b(:)
END SUBROUTINE Swap_Int32v
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two vectors of real, if blas95 is used then ignore it.
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int64v(a, b)
INTEGER(INT64), INTENT(INOUT) :: a(:), b(:)
END SUBROUTINE Swap_Int64v
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two vectors of real, if blas95 is used then ignore it.
+
#ifdef USE_Int128
INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int128v(a, b)
@@ -128,7 +219,7 @@ END SUBROUTINE Swap_Int128v
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -142,9 +233,13 @@ END SUBROUTINE Swap_c
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two vectors of complex numbers, if blas95 is used ignore it.
+
#ifndef USE_BLAS95
INTERFACE Swap
MODULE PURE SUBROUTINE Swap_cv(a, b)
@@ -154,9 +249,13 @@ END SUBROUTINE Swap_cv
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 22 March 2021
+! summary: Swap two matrix
+
INTERFACE Swap
MODULE PURE SUBROUTINE Swap_cm(a, b)
COMPLEX(DFPC), INTENT(INOUT) :: a(:, :), b(:, :)
@@ -164,7 +263,7 @@ END SUBROUTINE Swap_cm
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -178,7 +277,7 @@ END SUBROUTINE Swap_r32m
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -192,7 +291,7 @@ END SUBROUTINE Swap_r64m
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -203,24 +302,58 @@ END SUBROUTINE Swap_r64m
MODULE PURE SUBROUTINE Swap_Int8m(a, b)
INTEGER(INT8), INTENT(INOUT) :: a(:, :), b(:, :)
END SUBROUTINE Swap_Int8m
+END INTERFACE Swap
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrix
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int16m(a, b)
INTEGER(INT16), INTENT(INOUT) :: a(:, :), b(:, :)
END SUBROUTINE Swap_Int16m
+END INTERFACE Swap
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrix
+
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int32m(a, b)
INTEGER(INT32), INTENT(INOUT) :: a(:, :), b(:, :)
END SUBROUTINE Swap_Int32m
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrix
+INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int64m(a, b)
INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :)
END SUBROUTINE Swap_Int64m
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrix
+
#ifdef USE_Int128
INTERFACE Swap
MODULE PURE SUBROUTINE Swap_Int128m(a, b)
@@ -230,12 +363,12 @@ END SUBROUTINE Swap_Int128m
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
-! date: 2023-06-27
-! summary: Swap two scalars with masking
+! date: 2023-06-27
+! summary: Swap two scalars with masking
INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_r32s(a, b, mask)
@@ -245,7 +378,7 @@ END SUBROUTINE masked_Swap_r32s
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -260,7 +393,7 @@ END SUBROUTINE masked_Swap_r64s
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -272,17 +405,47 @@ MODULE PURE SUBROUTINE masked_Swap_Int8s(a, b, mask)
INTEGER(INT8), INTENT(INOUT) :: a, b
LOGICAL(LGT), INTENT(IN) :: mask
END SUBROUTINE masked_Swap_Int8s
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-27
+! summary: Swap two scalars with masking
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int16s(a, b, mask)
INTEGER(INT16), INTENT(INOUT) :: a, b
LOGICAL(LGT), INTENT(IN) :: mask
END SUBROUTINE masked_Swap_Int16s
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-27
+! summary: Swap two scalars with masking
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int32s(a, b, mask)
INTEGER(INT32), INTENT(INOUT) :: a, b
LOGICAL(LGT), INTENT(IN) :: mask
END SUBROUTINE masked_Swap_Int32s
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 2023-06-27
+! summary: Swap two scalars with masking
+
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int64s(a, b, mask)
INTEGER(INT64), INTENT(INOUT) :: a, b
LOGICAL(LGT), INTENT(IN) :: mask
@@ -290,7 +453,7 @@ END SUBROUTINE masked_Swap_Int64s
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -307,7 +470,7 @@ END SUBROUTINE masked_Swap_Int128s
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -322,7 +485,7 @@ END SUBROUTINE masked_Swap_r32v
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -337,7 +500,7 @@ END SUBROUTINE masked_Swap_r64v
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -349,17 +512,47 @@ MODULE PURE SUBROUTINE masked_Swap_Int8v(a, b, mask)
INTEGER(INT8), INTENT(INOUT) :: a(:), b(:)
LOGICAL(LGT), INTENT(IN) :: mask(:)
END SUBROUTINE masked_Swap_Int8v
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two vectors with masking
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int16v(a, b, mask)
INTEGER(INT16), INTENT(INOUT) :: a(:), b(:)
LOGICAL(LGT), INTENT(IN) :: mask(:)
END SUBROUTINE masked_Swap_Int16v
+END INTERFACE Swap
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two vectors with masking
+
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int32v(a, b, mask)
INTEGER(INT32), INTENT(INOUT) :: a(:), b(:)
LOGICAL(LGT), INTENT(IN) :: mask(:)
END SUBROUTINE masked_Swap_Int32v
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two vectors with masking
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int64v(a, b, mask)
INTEGER(INT64), INTENT(INOUT) :: a(:), b(:)
LOGICAL(LGT), INTENT(IN) :: mask(:)
@@ -367,7 +560,7 @@ END SUBROUTINE masked_Swap_Int64v
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -384,7 +577,7 @@ END SUBROUTINE masked_Swap_Int128v
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -399,7 +592,7 @@ END SUBROUTINE masked_Swap_r32m
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -414,7 +607,7 @@ END SUBROUTINE masked_Swap_r64m
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -426,17 +619,47 @@ MODULE PURE SUBROUTINE masked_Swap_Int8m(a, b, mask)
INTEGER(INT8), INTENT(INOUT) :: a(:, :), b(:, :)
LOGICAL(LGT), INTENT(IN) :: mask(:, :)
END SUBROUTINE masked_Swap_Int8m
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrices with masking
+
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int16m(a, b, mask)
INTEGER(INT16), INTENT(INOUT) :: a(:, :), b(:, :)
LOGICAL(LGT), INTENT(IN) :: mask(:, :)
END SUBROUTINE masked_Swap_Int16m
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrices with masking
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int32m(a, b, mask)
INTEGER(INT32), INTENT(INOUT) :: a(:, :), b(:, :)
LOGICAL(LGT), INTENT(IN) :: mask(:, :)
END SUBROUTINE masked_Swap_Int32m
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2025-10-14
+! summary: Swap two matrices with masking
+INTERFACE Swap
MODULE PURE SUBROUTINE masked_Swap_Int64m(a, b, mask)
INTEGER(INT64), INTENT(INOUT) :: a(:, :), b(:, :)
LOGICAL(LGT), INTENT(IN) :: mask(:, :)
@@ -444,7 +667,7 @@ END SUBROUTINE masked_Swap_Int64m
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -461,7 +684,7 @@ END SUBROUTINE masked_Swap_Int128m
#endif
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -492,7 +715,7 @@ END SUBROUTINE Swap_index1
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -521,10 +744,60 @@ MODULE PURE SUBROUTINE Swap_index2(a, b, i1, i2)
!! index 2 is Swapped with index `i2`
!! make sure i2 is less than or equal to 2
END SUBROUTINE Swap_index2
-END INTERFACE Swap
+END INTERFACE Swap
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-20
+! summary: Swap the index, it is like taking transpose.
+!
+!# Introduction
+!
+! - This routine returns an matrix by chaning the dimensions of input matrix
+! `b`.
+! - This routine does not check the shape, so make sure the shape of
+! `a` and `b` are appropriate,.
+!
+
+INTERFACE Swap_
+ MODULE PURE SUBROUTINE Swap_index_1(a, b, i1, i2)
+ REAL(REAL32), INTENT(INOUT) :: a(:, :)
+ !! the returned array
+ REAL(REAL32), INTENT(IN) :: b(:, :)
+ !! input array, it will be untouched
+ INTEGER(I4B), INTENT(IN) :: i1
+ !! index 1 is Swapped with index `i1`
+ !! make sure i1 is lesser than or equal to 2
+ INTEGER(I4B), INTENT(IN) :: i2
+ !! index 2 is Swapped with index `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
+ REAL(REAL64), INTENT(IN) :: b(:, :)
+ !! input array, it will be untouched
+ INTEGER(I4B), INTENT(IN) :: i1
+ !! index 1 is Swapped with index `i1`
+ !! make sure i1 is lesser than or equal to 2
+ INTEGER(I4B), INTENT(IN) :: i2
+ !! index 2 is Swapped with index `i2`
+ !! make sure i2 is less than or equal to 2
+ END SUBROUTINE Swap_index_2
+END INTERFACE Swap_
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -559,7 +832,7 @@ END SUBROUTINE Swap_index3
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -575,6 +848,74 @@ END SUBROUTINE Swap_index3
! `a` and `b` are appropriate,.
!
+INTERFACE Swap_
+ MODULE PURE SUBROUTINE Swap_index_3(a, b, i1, i2, i3)
+ REAL(REAL32), INTENT(INOUT) :: a(:, :, :)
+ !! the returned array
+ REAL(REAL32), INTENT(IN) :: b(:, :, :)
+ !! input array, it will be untouched
+ INTEGER(I4B), INTENT(IN) :: i1
+ !! index 1 is Swapped with index `i1`
+ !! make sure i1 is lesser than or equal to 3
+ INTEGER(I4B), INTENT(IN) :: i2
+ !! index 2 is Swapped with index `i2`
+ !! make sure i2 is less than or equal to 3
+ INTEGER(I4B), INTENT(IN) :: i3
+ !! index 3 is Swapped with index `i3`
+ !! make sure i3 is less than or equal to 3
+ END SUBROUTINE Swap_index_3
+END INTERFACE Swap_
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-20
+! update: 2021-11-20
+! summary: Swap the index, it is like taking transpose.
+!
+!# Introduction
+!
+! - This routine returns an matrix by chaning the dimensions of input matrix
+! `b`.
+! - This routine does not check the shape, so make sure the shape of
+! `a` and `b` are appropriate,.
+
+INTERFACE Swap_
+ MODULE PURE SUBROUTINE Swap_index_4(a, b, i1, i2, i3)
+ REAL(REAL64), INTENT(INOUT) :: a(:, :, :)
+ !! the returned array
+ REAL(REAL64), INTENT(IN) :: b(:, :, :)
+ !! input array, it will be untouched
+ INTEGER(I4B), INTENT(IN) :: i1
+ !! index 1 is Swapped with index `i1`
+ !! make sure i1 is lesser than or equal to 3
+ INTEGER(I4B), INTENT(IN) :: i2
+ !! index 2 is Swapped with index `i2`
+ !! make sure i2 is less than or equal to 3
+ INTEGER(I4B), INTENT(IN) :: i3
+ !! index 3 is Swapped with index `i3`
+ !! make sure i3 is less than or equal to 3
+ END SUBROUTINE Swap_index_4
+END INTERFACE Swap_
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-20
+! update: 2021-11-20
+! summary: Swap the index, it is like taking transpose.
+!
+!# Introduction
+!
+! - This routine returns an matrix by chaning the dimensions of input matrix
+! `b`.
+! - This routine does not check the shape, so make sure the shape of
+! `a` and `b` are appropriate,.
+
INTERFACE Swap
MODULE PURE SUBROUTINE Swap_index4(a, b, i1, i2, i3)
REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :)
@@ -594,7 +935,7 @@ END SUBROUTINE Swap_index4
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -631,7 +972,7 @@ END SUBROUTINE Swap_index5
END INTERFACE Swap
!----------------------------------------------------------------------------
-! Swap@SwapMethods
+! Swap@Methods
!----------------------------------------------------------------------------
!> author: Vikas Sharma, Ph. D.
@@ -667,6 +1008,72 @@ MODULE PURE SUBROUTINE Swap_index6(a, b, i1, i2, i3, i4)
END SUBROUTINE Swap_index6
END INTERFACE Swap
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-20
+! update: 2021-11-20
+! summary: Swap the index, it is like taking transpose.
+!
+!# Introduction
+!
+! - This routine returns an matrix by chaning the dimensions of input matrix
+! `b`.
+! - This routine does not check the shape, so make sure the shape of
+! `a` and `b` are appropriate,.
+
+INTERFACE Swap_
+ MODULE PURE SUBROUTINE Swap_index_5(a, b, i1, i2, i3, i4)
+ REAL(REAL32), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :)
+ !! the returned array
+ REAL(REAL32), INTENT(IN) :: b(:, :, :, :)
+ !! input array, it will be untouched
+ INTEGER(I4B), INTENT(IN) :: i1
+ !! index 1 is Swapped with index `i1`
+ !! make sure i1 is lesser than or equal to 4
+ INTEGER(I4B), INTENT(IN) :: i2
+ !! index 2 is Swapped with index `i2`
+ !! make sure i2 is less than or equal to 4
+ INTEGER(I4B), INTENT(IN) :: i3
+ !! index 3 is Swapped with index `i3`
+ !! make sure i3 is less than or equal to 4
+ INTEGER(I4B), INTENT(IN) :: i4
+ !! index 4 is Swapped with index `i4`
+ !! make sure i4 is less than or equal to 4
+ END SUBROUTINE Swap_index_5
+END INTERFACE Swap_
+
+!----------------------------------------------------------------------------
+! Swap@Methods
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 2021-11-20
+! summary: Swap the index, it is like taking transpose.
+
+INTERFACE Swap_
+ MODULE PURE SUBROUTINE Swap_index_6(a, b, i1, i2, i3, i4)
+ REAL(REAL64), ALLOCATABLE, INTENT(INOUT) :: a(:, :, :, :)
+ !! the returned array
+ REAL(REAL64), INTENT(IN) :: b(:, :, :, :)
+ !! input array, it will be untouched
+ INTEGER(I4B), INTENT(IN) :: i1
+ !! index 1 is Swapped with index `i1`
+ !! make sure i1 is lesser than or equal to 4
+ INTEGER(I4B), INTENT(IN) :: i2
+ !! index 2 is Swapped with index `i2`
+ !! make sure i2 is less than or equal to 4
+ INTEGER(I4B), INTENT(IN) :: i3
+ !! index 3 is Swapped with index `i3`
+ !! make sure i3 is less than or equal to 4
+ INTEGER(I4B), INTENT(IN) :: i4
+ !! index 4 is Swapped with index `i4`
+ !! make sure i4 is less than or equal to 4
+ END SUBROUTINE Swap_index_6
+END INTERFACE Swap_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90 b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90
index 4d3f08049..1353c3479 100644
--- a/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90
+++ b/src/submodules/BoundingBox/src/BoundingBox_Method@ConstructorMethods.F90
@@ -174,6 +174,29 @@
END IF
END PROCEDURE bb_deallocate2
+!----------------------------------------------------------------------------
+! Reallocate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Reallocate
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tempint
+
+isok = ALLOCATED(obj)
+
+IF (.NOT. isok) THEN
+ ALLOCATE (obj(tsize))
+ RETURN
+END IF
+
+tempint = SIZE(obj)
+isok = tempint .NE. tsize
+IF (isok) THEN
+ DEALLOCATE (obj)
+ ALLOCATE (obj(tsize))
+END IF
+END PROCEDURE obj_Reallocate
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/CMakeLists.txt b/src/submodules/CMakeLists.txt
index c6af0f192..ac3d6e7fb 100644
--- a/src/submodules/CMakeLists.txt
+++ b/src/submodules/CMakeLists.txt
@@ -27,6 +27,30 @@ include(${CMAKE_CURRENT_LIST_DIR}/MdEncode/CMakeLists.txt)
# Utility
include(${CMAKE_CURRENT_LIST_DIR}/Utility/CMakeLists.txt)
+# Point
+include(${CMAKE_CURRENT_LIST_DIR}/Point/CMakeLists.txt)
+
+# Line
+include(${CMAKE_CURRENT_LIST_DIR}/Line/CMakeLists.txt)
+
+# Triangle
+include(${CMAKE_CURRENT_LIST_DIR}/Triangle/CMakeLists.txt)
+
+# Quadrangle
+include(${CMAKE_CURRENT_LIST_DIR}/Quadrangle/CMakeLists.txt)
+
+# Tetrahedron
+include(${CMAKE_CURRENT_LIST_DIR}/Tetrahedron/CMakeLists.txt)
+
+# Hexahedron
+include(${CMAKE_CURRENT_LIST_DIR}/Hexahedron/CMakeLists.txt)
+
+# Prism
+include(${CMAKE_CURRENT_LIST_DIR}/Prism/CMakeLists.txt)
+
+# Pyramid
+include(${CMAKE_CURRENT_LIST_DIR}/Pyramid/CMakeLists.txt)
+
# Polynomial
include(${CMAKE_CURRENT_LIST_DIR}/Polynomial/CMakeLists.txt)
@@ -117,6 +141,9 @@ include(${CMAKE_CURRENT_LIST_DIR}/ForceVector/CMakeLists.txt)
# STForceVector
include(${CMAKE_CURRENT_LIST_DIR}/STForceVector/CMakeLists.txt)
+# Projection
+include(${CMAKE_CURRENT_LIST_DIR}/Projection/CMakeLists.txt)
+
# VoigtRank2Tensor
include(${CMAKE_CURRENT_LIST_DIR}/VoigtRank2Tensor/CMakeLists.txt)
diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90
index 15664fcb3..a36bcf6c0 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_AddMethods@Methods.F90
@@ -20,24 +20,43 @@
! summary: It contains method for setting values in [[CSRMatrix_]]
SUBMODULE(CSRMatrix_AddMethods) Methods
-USE BaseMethod
+USE GlobalData, ONLY: FMT_NODES, FMT_DOF, NodesToDOF, DofToNodes
+USE DOF_Method, ONLY: GetIndex, GetNodeLoc, OPERATOR(.tdof.), &
+ GetIndex_, GetNodeLoc_
+USE ConvertUtility, ONLY: Convert, Convert_
+USE CSRSparsity_Method, ONLY: CSR_SetIA => SetIA, CSR_SetJA => SetJA
+USE InputUtility, ONLY: Input
+USE F95_BLAS, ONLY: Scal, Copy
+USE ReallocateUtility, ONLY: Reallocate
+
+USE CSRMatrix_Method, ONLY: OPERATOR(.StorageFMT.), &
+ CSRMatrix_GetColIndex => GetColIndex, &
+ CSRMatrix_Size => Size, &
+ CSRMatrix_GetNNZ => GetNNZ, &
+ CSRMatrixAPLSB, &
+ CSRMatrixAPLSBSorted
+
IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = __FILE__
+#endif
+
CONTAINS
!----------------------------------------------------------------------------
! AddContribution
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_Add0
+MODULE PROCEDURE AddMaster1
! Internal variables
-INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
+INTEGER(I4B) :: ii, jj, kk, trow, tcol
-row = getIndex(obj=obj%csr%idof, nodeNum=nodenum)
-col = getIndex(obj=obj%csr%jdof, nodeNum=nodenum)
+trow = SIZE(row)
+tcol = SIZE(col)
-DO ii = 1, SIZE(row)
- DO kk = 1, SIZE(col)
+DO ii = 1, trow
+ DO kk = 1, tcol
DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
obj%A(jj) = obj%A(jj) + scale * VALUE(ii, kk)
@@ -46,10 +65,61 @@
END DO
END DO
END DO
+
+END PROCEDURE AddMaster1
+
+!----------------------------------------------------------------------------
+! AddMaster
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE AddMaster2
+! Internal variables
+INTEGER(I4B) :: ii, jj, kk, trow, tcol
+
+trow = SIZE(row)
+tcol = SIZE(col)
+
+DO ii = 1, trow
+ DO kk = 1, tcol
+ DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
+ IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
+ obj%A(jj) = obj%A(jj) + scale * VALUE
+ EXIT
+ END IF
+ END DO
+ END DO
+END DO
+
+END PROCEDURE AddMaster2
+
+!----------------------------------------------------------------------------
+! AddContribution
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add0
+! Internal variables
+INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
+
+row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum)
+col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum)
+
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
+
IF (ALLOCATED(row)) DEALLOCATE (row)
IF (ALLOCATED(col)) DEALLOCATE (col)
END PROCEDURE obj_Add0
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_0
+CALL GetIndex_(obj=obj%csr%idof, nodeNum=nodenum, ans=row, tsize=nrow)
+CALL GetIndex_(obj=obj%csr%jdof, nodeNum=nodenum, ans=col, tsize=ncol)
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_0
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
@@ -65,7 +135,7 @@
m2 = VALUE
ELSE
CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, &
- & nns=SIZE(nodenum), tDOF=tdof)
+ nns=SIZE(nodenum), tDOF=tdof)
END IF
CASE (FMT_DOF)
@@ -73,7 +143,7 @@
m2 = VALUE
ELSE
CALL Convert(From=VALUE, To=m2, Conversion=DofToNodes, &
- & nns=SIZE(nodenum), tDOF=tdof)
+ nns=SIZE(nodenum), tDOF=tdof)
END IF
END SELECT
@@ -82,6 +152,41 @@
END PROCEDURE obj_Add1
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_1
+INTEGER(I4B) :: tdof, nns, conversion, objStorageFMT
+LOGICAL(LGT) :: m2formed, isnode2dof
+
+objStorageFMT = (obj.StorageFMT.1)
+m2formed = storageFMT .EQ. objStorageFMT
+
+IF (m2formed) THEN
+ m2_nrow = 0
+ m2_ncol = 0
+ CALL Add_(obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, &
+ row=row, col=col, nrow=nrow, ncol=ncol)
+ RETURN
+END IF
+
+isnode2dof = (storageFMT .EQ. FMT_NODES) .AND. (objStorageFMT .EQ. FMT_DOF)
+IF (isnode2dof) THEN
+ conversion = NodesToDOF
+ELSE
+ conversion = DofToNodes
+END IF
+
+tdof = .tdof.obj%csr%idof
+nns = SIZE(nodenum)
+CALL Convert_(from=VALUE, to=m2, conversion=conversion, &
+ nns=nns, tDOF=tdof, nrow=m2_nrow, ncol=m2_ncol)
+
+CALL Add_(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale, &
+ row=row, col=col, nrow=nrow, ncol=ncol)
+END PROCEDURE obj_Add_1
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
@@ -95,10 +200,13 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_Add3
-INTEGER(I4B) :: i, j
-DO j = obj%csr%IA(iRow), obj%csr%IA(iRow + 1) - 1
- IF (obj%csr%JA(j) .EQ. iColumn) &
- & obj%A(j) = obj%A(j) + scale * VALUE
+INTEGER(I4B) :: j
+
+DO j = obj%csr%IA(irow), obj%csr%IA(irow + 1) - 1
+ IF (obj%csr%JA(j) .EQ. icolumn) THEN
+ obj%A(j) = obj%A(j) + scale * VALUE
+ EXIT
+ END IF
END DO
END PROCEDURE obj_Add3
@@ -107,12 +215,11 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_Add4
-!
-CALL Add(obj=obj, &
- & irow=getNodeLoc(obj=obj%csr%idof, nodenum=inodenum, idof=idof), &
- & icolumn=getNodeLoc(obj=obj%csr%jdof, nodenum=jnodenum, idof=jdof), &
- & VALUE=VALUE, scale=scale)
-!
+INTEGER(I4B) :: irow, icolumn
+
+irow = GetNodeLoc(obj=obj%csr%idof, nodenum=inodenum, idof=idof)
+icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jnodenum, idof=jdof)
+CALL Add_(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, scale=scale)
END PROCEDURE obj_Add4
!----------------------------------------------------------------------------
@@ -122,14 +229,29 @@
MODULE PROCEDURE obj_Add5
REAL(DFP), ALLOCATABLE :: m2(:, :)
INTEGER(I4B) :: tdof1, tdof2
+
tdof1 = .tdof.obj%csr%idof
tdof2 = .tdof.obj%csr%jdof
+
ALLOCATE (m2(tdof1 * SIZE(nodenum), tdof2 * SIZE(nodenum)))
+
m2 = VALUE
+
CALL Add(obj=obj, nodenum=nodenum, VALUE=m2, scale=scale)
DEALLOCATE (m2)
END PROCEDURE obj_Add5
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_5
+CALL GetIndex_(obj=obj%csr%idof, nodeNum=nodenum, ans=row, tsize=nrow)
+CALL GetIndex_(obj=obj%csr%jdof, nodeNum=nodenum, ans=col, tsize=ncol)
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_5
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
@@ -137,45 +259,41 @@
MODULE PROCEDURE obj_Add6
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
-row = getIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar)
-col = getIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar)
+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 kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE(ii, kk)
- EXIT
- END IF
- END DO
- END DO
-END DO
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
-
END PROCEDURE obj_Add6
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_6
+CALL GetIndex_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, ans=row, &
+ tsize=nrow)
+CALL GetIndex_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, ans=col, &
+ tsize=ncol)
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_6
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_Add7
-CALL Add(obj=obj, &
- & irow=getNodeLoc( &
- & obj=obj%csr%idof, &
- & nodenum=iNodeNum, &
- & ivar=ivar, &
- & idof=iDOF),&
- & icolumn=getNodeLoc( &
- & obj=obj%csr%jdof, &
- & nodenum=jNodeNum, &
- & ivar=jvar, &
- & idof=jDOF), &
- & VALUE=VALUE, &
- & scale=scale)
-!
+INTEGER(I4B) :: irow, icolumn
+
+irow = GetNodeLoc(obj=obj%csr%idof, nodenum=iNodeNum, ivar=ivar, &
+ idof=idof)
+icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, &
+ idof=jdof)
+
+CALL Add_(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, scale=scale)
END PROCEDURE obj_Add7
!----------------------------------------------------------------------------
@@ -185,46 +303,40 @@
MODULE PROCEDURE obj_Add8
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
-row = getIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof)
-col = getIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof)
+row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof)
+col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof)
-DO ii = 1, SIZE(row)
- DO kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE(ii, kk)
- EXIT
- END IF
- END DO
- END DO
-END DO
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
END PROCEDURE obj_Add8
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_8
+CALL GetIndex_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof, &
+ ans=row, tsize=nrow)
+CALL GetIndex_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof, &
+ ans=col, tsize=ncol)
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_8
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_Add9
-CALL Add( &
- & obj=obj, &
- & 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), &
- & VALUE=VALUE, &
- & scale=scale)
+INTEGER(I4B) :: irow, icolumn
+
+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)
+CALL Add_(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, scale=scale)
END PROCEDURE obj_Add9
!----------------------------------------------------------------------------
@@ -234,25 +346,28 @@
MODULE PROCEDURE obj_Add10
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
!
-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 kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE
- EXIT
- END IF
- END DO
- END DO
-END DO
+row = GetIndex(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar)
+col = GetIndex(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar)
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
END PROCEDURE obj_Add10
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_10
+CALL GetIndex_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ ans=row, tsize=nrow)
+CALL GetIndex_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ ans=col, tsize=ncol)
+
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), &
+ VALUE=VALUE, scale=scale)
+END PROCEDURE obj_Add_10
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
@@ -260,26 +375,27 @@
MODULE PROCEDURE obj_Add11
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
-
-row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof)
-col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof)
-DO ii = 1, SIZE(row)
- DO kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE
- EXIT
- END IF
- END DO
- END DO
-END DO
+row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof)
+col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof)
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
-
END PROCEDURE obj_Add11
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_11
+CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, idof=idof, &
+ ans=row, tsize=nrow)
+CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, idof=jdof, &
+ ans=col, tsize=ncol)
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_11
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
@@ -287,24 +403,14 @@
MODULE PROCEDURE obj_Add12
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
-row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
- & spacecompo=ispacecompo, timecompo=itimecompo)
+row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo)
-col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
- & spacecompo=jspacecompo, timecompo=jtimecompo)
+col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo)
-DO ii = 1, SIZE(row)
- DO kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE
- EXIT
- END IF
- END DO
- END DO
-END DO
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
END PROCEDURE obj_Add12
@@ -313,32 +419,53 @@
! Add
!----------------------------------------------------------------------------
+MODULE PROCEDURE obj_Add_12
+CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo, &
+ ans=row, tsize=nrow)
+
+CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo, &
+ ans=col, tsize=ncol)
+
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_12
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE obj_Add13
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
-row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
- & spacecompo=ispacecompo, timecompo=itimecompo)
+row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo)
-col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
- & spacecompo=jspacecompo, timecompo=jtimecompo)
-
-DO ii = 1, SIZE(row)
- DO kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE
- EXIT
- END IF
- END DO
- END DO
-END DO
+col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo)
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
-
END PROCEDURE obj_Add13
+!----------------------------------------------------------------------------
+! Add_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add_13
+CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo, &
+ ans=row, tsize=nrow)
+
+CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo, &
+ ans=col, tsize=ncol)
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_13
+
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
@@ -346,34 +473,44 @@
MODULE PROCEDURE obj_Add14
! Internal variables
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
-INTEGER(I4B) :: ii, jj, kk
-
-row = getNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
- & spacecompo=ispacecompo, timecompo=itimecompo)
-col = getNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
- & spacecompo=jspacecompo, timecompo=jtimecompo)
+row = GetNodeLoc(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo)
-DO ii = 1, SIZE(row)
- DO kk = 1, SIZE(col)
- DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
- IF (obj%csr%JA(jj) .EQ. col(kk)) THEN
- obj%A(jj) = obj%A(jj) + scale * VALUE
- EXIT
- END IF
- END DO
- END DO
-END DO
+col = GetNodeLoc(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo)
+CALL AddMaster(obj=obj, row=row, col=col, VALUE=VALUE, scale=scale)
DEALLOCATE (row, col)
-
END PROCEDURE obj_Add14
!----------------------------------------------------------------------------
! Add
!----------------------------------------------------------------------------
+MODULE PROCEDURE obj_Add_14
+CALL GetNodeLoc_(obj=obj%csr%idof, nodeNum=iNodeNum, ivar=ivar, &
+ spacecompo=ispacecompo, timecompo=itimecompo, &
+ ans=row, tsize=nrow)
+
+CALL GetNodeLoc_(obj=obj%csr%jdof, nodeNum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo, &
+ ans=col, tsize=ncol)
+
+CALL AddMaster(obj=obj, row=row(1:nrow), col=col(1:ncol), VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add_14
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE obj_Add15
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_Add15()"
+LOGICAL(LGT) :: isok
+#endif
+
LOGICAL(LGT) :: sameStructure0, isSorted0
INTEGER(I4B) :: nrow, ncol, nzmax, ierr
@@ -386,35 +523,73 @@
isSorted0 = Input(default=.FALSE., option=isSorted)
-nrow = SIZE(obj, 1)
-ncol = SIZE(obj, 2)
-nzmax = GetNNZ(obj)
+nrow = CSRMatrix_SIZE(obj, 1)
+ncol = CSRMatrix_SIZE(obj, 2)
+nzmax = CSRMatrix_GetNNZ(obj)
IF (isSorted0) THEN
- CALL CSRMatrixAPLSBSorted(nrow=nrow, ncol=ncol, &
- & a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, &
- & s=scale, &
- & b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, &
- & c=obj%A, jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, &
- & ierr=ierr)
+ CALL CSRMatrixAPLSBSorted( &
+ nrow=nrow, ncol=ncol, a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, &
+ s=scale, b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, c=obj%A, &
+ jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, ierr=ierr)
+
ELSE
- CALL CSRMatrixAPLSB(nrow=nrow, ncol=ncol, &
- & a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, &
- & s=scale, &
- & b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, &
- & c=obj%A, jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, &
- & ierr=ierr)
+ CALL CSRMatrixAPLSB( &
+ nrow=nrow, ncol=ncol, a=obj%A, ja=obj%csr%ja, ia=obj%csr%ia, &
+ s=scale, b=VALUE%a, jb=VALUE%csr%ja, ib=VALUE%csr%ia, &
+ c=obj%A, jc=obj%csr%ja, ic=obj%csr%ia, nzmax=nzmax, &
+ ierr=ierr)
END IF
-IF (ierr .EQ. 0) THEN
- CALL Errormsg( &
- & "Some error occured while calling CSRMarixAPLSB.", &
- & __FILE__, &
- & "obj_Add15()", &
- & __LINE__, &
- & stderr)
- STOP
-END IF
+#ifdef DEBUG_VER
+isok = ierr .NE. 0
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "Some error occured while calling CSRMarixAPLSB.")
+#endif
END PROCEDURE obj_Add15
+!----------------------------------------------------------------------------
+! AddToSTMatrix
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_AddToSTMatrix1
+REAL(DFP) :: scale0
+INTEGER(I4B) :: icol
+INTEGER(I4B) :: irow_rhs, trow_rhs, icol_rhs, colIndex_rhs(2), &
+ tcol_rhs
+INTEGER(I4B) :: irow_lhs, icol_lhs, colIndex_lhs(2), &
+ offAdd_row_lhs, offAdd_col_lhs
+
+scale0 = Input(default=1.0_DFP, option=scale)
+
+trow_rhs = CSRMatrix_Size(obj=VALUE, dims=1)
+offAdd_row_lhs = (itimecompo - 1) * trow_rhs
+
+! start row loop
+DO irow_rhs = 1, trow_rhs
+ ! Get the starting and ending data index for irow in value
+ colIndex_rhs = CSRMatrix_GetColIndex(obj=VALUE, irow=irow_rhs)
+ tcol_rhs = colIndex_rhs(2) - colIndex_rhs(1) + 1
+
+ ! Calculate the column offAdd for lhs
+ offAdd_col_lhs = (jtimecompo - 1) * tcol_rhs
+
+ irow_lhs = offAdd_row_lhs + irow_rhs
+ colIndex_lhs = CSRMatrix_GetColIndex(obj=obj, irow=irow_lhs)
+
+ DO icol = 1, tcol_rhs
+ icol_rhs = colIndex_rhs(1) + icol - 1
+ icol_lhs = colIndex_lhs(1) + offAdd_col_lhs + icol - 1
+
+ obj%A(icol_lhs) = obj%A(icol_lhs) + scale0 * VALUE%A(icol_rhs)
+ END DO
+END DO
+END PROCEDURE obj_AddToSTMatrix1
+
+!----------------------------------------------------------------------------
+! Include Errror
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
END SUBMODULE Methods
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..5b2ba7383 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetMethods@Methods.F90
@@ -30,6 +30,11 @@
USE ErrorHandling
USE GlobalData, ONLY: DofToNodes, NodesToDOF, FMT_NODES, FMT_DOF, stderr
IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = "CSRMatrix_GetMethods@Methods.F90"
+#endif
+
CONTAINS
!----------------------------------------------------------------------------
@@ -160,21 +165,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 +206,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 +241,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)
@@ -229,25 +251,6 @@
END PROCEDURE obj_Get2
-!----------------------------------------------------------------------------
-! GetValue
-!----------------------------------------------------------------------------
-
-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))
- END DO
-END DO
-
-END PROCEDURE obj_Get10
-
!----------------------------------------------------------------------------
! GetValue
!----------------------------------------------------------------------------
@@ -271,10 +274,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
@@ -298,20 +304,19 @@
!----------------------------------------------------------------------------
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
@@ -326,59 +331,23 @@
MODULE PROCEDURE obj_Get7
INTEGER(I4B) :: irow, icolumn
-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)
-
+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)
CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE)
END PROCEDURE obj_Get7
-!----------------------------------------------------------------------------
-! GetValue
-!----------------------------------------------------------------------------
-
-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)
-
-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
-END PROCEDURE obj_Get9
-
!----------------------------------------------------------------------------
! GetValue
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_Get8
-CHARACTER(*), PARAMETER :: myName = "CSR2CSR_Get_Master()"
-CHARACTER(*), PARAMETER :: filename = __FILE__
-INTEGER(I4B) :: myindx(6, 2), idof1, jdof1, idof2, jdof2, &
- & row1, row2, col1, col2, ierr0
+CHARACTER(*), PARAMETER :: myName = "obj_Get8()"
+INTEGER(I4B) :: myindx(6, 2), idof1, jdof1, idof2, jdof2, &
+ row1, row2, col1, col2
CLASS(DOF_), POINTER :: dof_obj
-LOGICAL(LGT) :: problem
+LOGICAL(LGT) :: isok
! 1 ivar
! 2 ispacecompo
@@ -387,7 +356,8 @@
! 5 jspacecompo
! 6 jtimecompo
-IF (PRESENT(ierr)) ierr = 0
+isok = PRESENT(ierr)
+IF (isok) ierr = 0
myindx(1, 1) = Input(default=1, option=ivar1)
myindx(2, 1) = Input(default=1, option=ispacecompo1)
@@ -406,96 +376,120 @@
NULLIFY (dof_obj)
dof_obj => GetDOFPointer(obj1, 1)
-problem = .NOT. ASSOCIATED(dof_obj)
-IF (problem) THEN
- CALL ErrorMSG( &
- & "Cannot get idof pointer from obj1", &
- & filename, &
- & myName, &
- & __LINE__, stderr)
- ierr0 = -1
- IF (PRESENT(ierr)) ierr = ierr0
- RETURN
-END IF
-idof1 = GetIDOF(obj=dof_obj, &
- & ivar=myindx(1, 1), &
- & spacecompo=myindx(2, 1), &
- & timecompo=myindx(3, 1))
+
+#ifdef DEBUG_VER
+isok = ASSOCIATED(dof_obj)
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "dof_obj is not associated.")
+#endif
+
+idof1 = GetIDOF(obj=dof_obj, ivar=myindx(1, 1), spacecompo=myindx(2, 1), &
+ timecompo=myindx(3, 1))
row1 = dof_obj.tNodes.idof1
dof_obj => GetDOFPointer(obj1, 2)
-problem = .NOT. ASSOCIATED(dof_obj)
-IF (problem) THEN
- CALL ErrorMSG( &
- & "Cannot get jdof pointer from obj1", &
- & filename, &
- & myName, &
- & __LINE__, stderr)
- ierr0 = -2
- IF (PRESENT(ierr)) ierr = ierr0
- RETURN
-END IF
-jdof1 = GetIDOF(obj=dof_obj, &
- & ivar=myindx(4, 1), &
- & spacecompo=myindx(5, 1), &
- & timecompo=myindx(6, 1))
+
+#ifdef DEBUG_VER
+isok = ASSOCIATED(dof_obj)
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "dof_obj is not associated.")
+#endif
+
+jdof1 = GetIDOF(obj=dof_obj, ivar=myindx(4, 1), spacecompo=myindx(5, 1), &
+ timecompo=myindx(6, 1))
col1 = dof_obj.tNodes.jdof1
dof_obj => GetDOFPointer(obj2, 1)
-problem = .NOT. ASSOCIATED(dof_obj)
-IF (problem) THEN
- CALL ErrorMSG( &
- & "Cannot get idof pointer from obj2", &
- & filename, &
- & myName, &
- & __LINE__, stderr)
- ierr0 = -3
- IF (PRESENT(ierr)) ierr = ierr0
- RETURN
-END IF
-idof2 = GetIDOF(obj=dof_obj, &
- & ivar=myindx(1, 2), &
- & spacecompo=myindx(2, 2), &
- & timecompo=myindx(3, 2))
+
+#ifdef DEBUG_VER
+isok = ASSOCIATED(dof_obj)
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "dof_obj is not associated.")
+#endif
+
+idof2 = GetIDOF(obj=dof_obj, ivar=myindx(1, 2), spacecompo=myindx(2, 2), &
+ timecompo=myindx(3, 2))
row2 = dof_obj.tNodes.idof2
dof_obj => GetDOFPointer(obj2, 2)
-problem = .NOT. ASSOCIATED(dof_obj)
-IF (problem) THEN
- CALL ErrorMSG( &
- & "Cannot get jdof pointer from obj2", &
- & filename, &
- & myName, &
- & __LINE__, stderr)
- ierr0 = -4
- IF (PRESENT(ierr)) ierr = ierr0
- RETURN
-END IF
-jdof2 = GetIDOF(obj=dof_obj, &
- & ivar=myindx(4, 2), &
- & spacecompo=myindx(5, 2), &
- & timecompo=myindx(6, 2))
+
+#ifdef DEBUG_VER
+isok = ASSOCIATED(dof_obj)
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "dof_obj is not associated.")
+#endif
+
+jdof2 = GetIDOF(obj=dof_obj, ivar=myindx(4, 2), spacecompo=myindx(5, 2), &
+ timecompo=myindx(6, 2))
+
col2 = dof_obj.tNodes.jdof2
NULLIFY (dof_obj)
-problem = (row1 .NE. row2) .OR. (col1 .NE. col2)
-IF (problem) THEN
- CALL ErrorMSG( &
- & "Some error occured in sizes.", &
- & filename, &
- & myName, &
- & __LINE__, stderr)
- ierr0 = -5
- IF (PRESENT(ierr)) ierr = ierr0
- RETURN
-END IF
-
-CALL CSR2CSR_Get_Master(obj1=obj1, obj2=obj2, idof1=idof1, idof2=idof2, &
-& jdof1=jdof1, jdof2=jdof2, tNodes1=row1, tNodes2=col1)
+#ifdef DEBUG_VER
+isok = (row1 .EQ. row2) .AND. (col1 .EQ. col2)
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "Some error occured in sizes.")
+#endif
+CALL CSR2CSR_Get_Master(obj1=obj1, obj2=obj2, idof1=idof1, idof2=idof2, &
+ jdof1=jdof1, jdof2=jdof2, tNodes1=row1, tNodes2=col1)
END PROCEDURE obj_Get8
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+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)
+
+icolumn = GetNodeLoc(obj=obj%csr%jdof, nodenum=jNodeNum, ivar=jvar, &
+ spacecompo=jspacecompo, timecompo=jtimecompo)
+
+CALL GetValue(obj=obj, irow=irow, icolumn=icolumn, VALUE=VALUE, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE obj_Get9
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get10
+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
+
+END PROCEDURE obj_Get10
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get11
+ans = obj%A(indx)
+END PROCEDURE obj_Get11
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get12
+INTEGER(I4B) :: ii
+tsize = SIZE(indx)
+DO ii = 1, tsize; ans(ii) = obj%A(indx(ii)); END DO
+END PROCEDURE obj_Get12
+
!----------------------------------------------------------------------------
! CSR2CSRGetValue
!----------------------------------------------------------------------------
@@ -505,22 +499,19 @@
REAL(DFP) :: VALUE
DO jj = 1, tNodes2
DO ii = 1, tNodes1
- CALL GetValue(obj=obj1, &
- & idof=idof1, &
- & jdof=jdof1, &
- & iNodeNum=ii, &
- & jNodeNum=jj, &
- & VALUE=VALUE)
-
- CALL Set(obj=obj2, &
- & idof=idof2, &
- & jdof=jdof2, &
- & iNodeNum=ii, &
- & jNodeNum=jj, &
- & VALUE=VALUE)
+ CALL GetValue(obj=obj1, idof=idof1, jdof=jdof1, iNodeNum=ii, &
+ jNodeNum=jj, VALUE=VALUE)
+
+ CALL Set(obj=obj2, idof=idof2, jdof=jdof2, iNodeNum=ii, jNodeNum=jj, &
+ VALUE=VALUE)
END DO
END DO
-
END PROCEDURE CSR2CSR_Get_Master
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
END SUBMODULE Methods
diff --git a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90
index 57773f75f..e6499613d 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_GetSubMatrixMethods@Methods.F90
@@ -15,110 +15,171 @@
! along with this program. If not, see
SUBMODULE(CSRMatrix_GetSubMatrixMethods) Methods
-USE BaseMethod
+USE Display_Method, ONLY: ToString, Display
+USE BaseType, ONLY: math => TypeMathOpt
+USE CSRMatrix_Method, ONLY: GetNNZ
+USE CSRMatrix_Method, ONLY: CSRMatrix_GetColIndex => GetColIndex
+USE CSRMatrix_Method, ONLY: CSRMatrix_GetColNumber => GetColNumber
+USE CSRMatrix_Method, ONLY: CSRMatrix_Size => SIZE
+USE CSRMatrix_Method, ONLY: CSRMatrix_GetSingleValue => GetSingleValue
+USE CSRMatrix_Method, ONLY: CSRMatrix_SetIA => SetIA
+USE CSRMatrix_Method, ONLY: CSRMatrix_SetJA => SetJA
+USE CSRMatrix_Method, ONLY: CSRMatrix_SetSingleValue => SetSingleValue
+USE CSRMatrix_Method, ONLY: CSRMatrix_GetValue => GetValue
+USE CSRMatrix_Method, ONLY: CSRMatrix_Initiate => Initiate
+USE CSRSparsity_Method, ONLY: CSR_GetColNumber => GetColNumber
+USE ReallocateUtility, ONLY: Reallocate
+
IMPLICIT NONE
+
+CHARACTER(*), PARAMETER :: modName="CSRMatrix_GetSubMatrixMethods@Methods.F90"
+
CONTAINS
!----------------------------------------------------------------------------
-! GetSubMatrix
+! GetSubMatrixNNZ
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_GetSubMatrix1
-LOGICAL(LGT), ALLOCATABLE :: selectCol(:)
-INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, nn, irow, colIndx(2), &
-& icol, jj
-REAL(DFP) :: aval
-TYPE(String) :: astr
+MODULE PROCEDURE obj_GetSubMatrixNNZ
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetSubMatrixNNZ()"
+LOGICAL(LGT) :: isok
+#endif
+
+INTEGER(I4B) :: nnz, nrow, ncol, ii, nn, irow, colIndx(2), &
+ icol, jj
nnz = GetNNZ(obj=obj)
-nrow = SIZE(obj, 1)
-ncol = SIZE(obj, 2)
+nrow = CSRMatrix_Size(obj, 1)
+ncol = CSRMatrix_Size(obj, 2)
-CALL Reallocate(selectCol, ncol)
+! CALL Reallocate(selectCol, ncol)
-selectCol = .FALSE.
+selectCol(1:ncol) = math%no
nn = SIZE(cols)
DO ii = 1, nn
jj = cols(ii)
- 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)
- STOP
- END IF
- selectCol(jj) = .TRUE.
+
+#ifdef DEBUG_VER
+ isok = jj .LE. ncol
+ CALL AssertError1( &
+ isok, myName, modName, __LINE__, "Error cols( "//ToString(ii)// &
+ ") is greater than ncol = "//ToString(ncol))
+#endif
+
+ selectCol(jj) = math%yes
END DO
-submat_nnz = 0
+ans = 0
DO irow = 1, nrow
- colIndx = GetColIndex(obj=obj, irow=irow)
+ colIndx = CSRMatrix_GetColIndex(obj=obj, irow=irow)
DO ii = colIndx(1), colIndx(2)
- icol = GetColNumber(obj, ii)
- IF (selectCol(icol)) submat_nnz = submat_nnz + 1
+ icol = CSRMatrix_GetColNumber(obj, ii)
+ IF (selectCol(icol)) ans = ans + 1
END DO
END DO
+END PROCEDURE obj_GetSubMatrixNNZ
+
+!----------------------------------------------------------------------------
+! GetSubMatrix
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetSubMatrix1
+LOGICAL(LGT), ALLOCATABLE :: selectCol(:)
+INTEGER(I4B) :: tsize
+tsize = CSRMatrix_Size(obj, 2)
+CALL Reallocate(selectCol, tsize)
+CALL GetSubMatrixNNZ(obj=obj, cols=cols, selectCol=selectCol, ans=tsize)
+CALL Reallocate(subIndices, tsize)
+CALL GetSubMatrix_( &
+ obj=obj, cols=cols, submat=submat, subIndices=subIndices, &
+ selectCol=selectCol, tsize=tsize)
+IF (ALLOCATED(selectCol)) DEALLOCATE (selectCol)
+END PROCEDURE obj_GetSubMatrix1
+
+!----------------------------------------------------------------------------
+! GetSubMatrix
+!----------------------------------------------------------------------------
-CALL Reallocate(subIndices, submat_nnz)
-CALL Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=submat_nnz)
+MODULE PROCEDURE obj_GetSubMatrix_1
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetSubMatrix_1()"
+#endif
+
+INTEGER(I4B) :: nnz, nrow, ncol, submat_nnz, ii, irow, colIndx(2), icol, jj
+REAL(DFP) :: aval
+
+nnz = GetNNZ(obj=obj)
+nrow = CSRMatrix_Size(obj, 1)
+ncol = CSRMatrix_Size(obj, 2)
+
+! CALL Reallocate(selectCol, ncol)
+CALL GetSubMatrixNNZ(obj=obj, cols=cols, selectCol=selectCol, ans=submat_nnz)
+
+! CALL Reallocate(subIndices, submat_nnz)
+CALL CSRMatrix_Initiate(obj=submat, ncol=ncol, nrow=nrow, nnz=submat_nnz)
submat_nnz = 1
-CALL SetIA(obj=submat, irow=1, VALUE=submat_nnz)
+CALL CSRMatrix_SetIA(obj=submat, irow=1, VALUE=submat_nnz)
DO irow = 1, nrow
- colIndx = GetColIndex(obj=obj, irow=irow)
+ colIndx = CSRMatrix_GetColIndex(obj=obj, irow=irow)
+
jj = 0
DO ii = colIndx(1), colIndx(2)
- icol = GetColNumber(obj%csr, ii)
+ icol = CSR_GetColNumber(obj%csr, ii)
+
IF (selectCol(icol)) THEN
- CALL SetJA(obj=submat, indx=submat_nnz + jj, VALUE=icol)
- aval = GetSingleValue(obj=obj, indx=ii)
- CALL SetSingleValue(obj=submat, indx=submat_nnz + jj, VALUE=aval)
+ CALL CSRMatrix_SetJA(obj=submat, indx=submat_nnz + jj, VALUE=icol)
+
+ aval = CSRMatrix_GetSingleValue(obj=obj, indx=ii)
+
+ CALL CSRMatrix_SetSingleValue( &
+ obj=submat, indx=submat_nnz + jj, VALUE=aval)
+
subIndices(submat_nnz + jj) = ii
+
jj = jj + 1
END IF
END DO
- submat_nnz = submat_nnz + jj
- CALL SetIA(obj=submat, irow=irow + 1, VALUE=submat_nnz)
-END DO
-IF (ALLOCATED(selectCol)) DEALLOCATE (selectCol)
+ submat_nnz = submat_nnz + jj
+ CALL CSRMatrix_SetIA(obj=submat, irow=irow + 1, VALUE=submat_nnz)
-END PROCEDURE obj_GetSubMatrix1
+END DO
+END PROCEDURE obj_GetSubMatrix_1
!----------------------------------------------------------------------------
! GetSubMatrix1
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetSubMatrix2
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetSubMatrix2()"
+#endif
LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tsize
+#ifdef DEBUG_VER
isok = ALLOCATED(submat%A)
-IF (.NOT. isok) THEN
- CALL ErrorMSG( &
- & "submat%A not allocated", &
- & "CSRMatrix_GetSubMatrixMethods@Methods.F90", &
- & "obj_GetSubMatrix2()", &
- & __LINE__, stderr)
- STOP
-END IF
+CALL AssertError1( &
+ isok, myName, modName, __LINE__, "submat%A is not allocated")
+#endif
+#ifdef DEBUG_VER
isok = SIZE(submat%A) .EQ. SIZE(subIndices)
-IF (.NOT. isok) THEN
- CALL ErrorMSG( &
- & "Size of submat%A not same as size of subIndices.", &
- & "CSRMatrix_GetSubMatrixMethods@Methods.F90", &
- & "obj_GetSubMatrix2()", &
- & __LINE__, stderr)
- STOP
-END IF
-
-submat%A = Get(obj=obj, indx=subIndices)
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "Size of submat%A not same as size of subIndices.")
+#endif
+CALL CSRMatrix_GetValue(obj=obj, indx=subIndices, ans=submat%A, tsize=tsize)
END PROCEDURE obj_GetSubMatrix2
+!----------------------------------------------------------------------------
+! Include Error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
END SUBMODULE Methods
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/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90 b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90
index 8283f5447..7e9f07ab0 100644
--- a/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90
+++ b/src/submodules/CSRMatrix/src/CSRMatrix_SetMethods@Methods.F90
@@ -20,7 +20,18 @@
! summary: It contains method for setting values in [[CSRMatrix_]]
SUBMODULE(CSRMatrix_SetMethods) Methods
-USE BaseMethod
+USE GlobalData, ONLY: FMT_NODES, FMT_DOF, NodesToDOF, DofToNodes
+USE DOF_Method, ONLY: GetIndex, GetNodeLoc, OPERATOR(.tdof.)
+USE ConvertUtility, ONLY: Convert
+USE CSRSparsity_Method, ONLY: CSR_SetIA => SetIA, CSR_SetJA => SetJA
+USE InputUtility, ONLY: Input
+USE F95_BLAS, ONLY: Scal, Copy
+USE ReallocateUtility, ONLY: Reallocate
+
+USE CSRMatrix_GetMethods, ONLY: OPERATOR(.StorageFMT.), &
+ CSRMatrix_GetColIndex => GetColIndex
+USE CSRMatrix_ConstructorMethods, ONLY: CSRMatrix_Size => Size
+
IMPLICIT NONE
CONTAINS
@@ -41,8 +52,8 @@
INTEGER(I4B), ALLOCATABLE :: row(:), col(:)
INTEGER(I4B) :: ii, jj, kk
-row = getIndex(obj=obj%csr%idof, nodeNum=nodenum)
-col = getIndex(obj=obj%csr%jdof, nodeNum=nodenum)
+row = GetIndex(obj=obj%csr%idof, nodeNum=nodenum)
+col = GetIndex(obj=obj%csr%jdof, nodeNum=nodenum)
DO ii = 1, SIZE(row)
DO kk = 1, SIZE(col)
DO jj = obj%csr%IA(row(ii)), obj%csr%IA(row(ii) + 1) - 1
@@ -72,14 +83,14 @@
m2 = VALUE
ELSE
CALL Convert(From=VALUE, To=m2, Conversion=NodesToDOF, &
- & nns=SIZE(nodenum), tDOF=tdof)
+ nns=SIZE(nodenum), tDOF=tdof)
END IF
CASE (FMT_DOF)
IF ((obj.StorageFMT.1) .EQ. FMT_DOF) THEN
m2 = VALUE
ELSE
CALL Convert(From=VALUE, To=m2, Conversion=DofToNodes, &
- & nns=SIZE(nodenum), tDOF=tdof)
+ nns=SIZE(nodenum), tDOF=tdof)
END IF
END SELECT
CALL Set(obj=obj, nodenum=nodenum, VALUE=m2)
@@ -378,9 +389,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_set15
-CALL COPY(Y=obj%A, X=VALUE%A)
+CALL Copy(Y=obj%A, X=VALUE%A)
IF (PRESENT(scale)) THEN
- CALL SCAL(X=obj%A, A=scale)
+ CALL Scal(X=obj%A, A=scale)
END IF
END PROCEDURE obj_set15
@@ -389,7 +400,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_SetIA
-CALL SetIA(obj%csr, irow, VALUE)
+CALL CSR_SetIA(obj=obj%csr, irow=irow, VALUE=VALUE)
END PROCEDURE obj_SetIA
!----------------------------------------------------------------------------
@@ -397,7 +408,46 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_SetJA
-CALL SetJA(obj%csr, indx, VALUE)
+CALL CSR_SetJA(obj=obj%csr, indx=indx, VALUE=VALUE)
END PROCEDURE obj_SetJA
+!----------------------------------------------------------------------------
+! SetToSTMatrix
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_SetToSTMatrix1
+REAL(DFP) :: scale0
+INTEGER(I4B) :: icol
+INTEGER(I4B) :: irow_rhs, trow_rhs, icol_rhs, colIndex_rhs(2), &
+ tcol_rhs
+INTEGER(I4B) :: irow_lhs, icol_lhs, colIndex_lhs(2), &
+ offset_row_lhs, offset_col_lhs
+
+scale0 = Input(default=1.0_DFP, option=scale)
+
+trow_rhs = CSRMatrix_Size(obj=VALUE, dims=1)
+offset_row_lhs = (itimecompo - 1) * trow_rhs
+
+! start row loop
+DO irow_rhs = 1, trow_rhs
+ ! Get the starting and ending data index for irow in value
+ colIndex_rhs = CSRMatrix_GetColIndex(obj=VALUE, irow=irow_rhs)
+ tcol_rhs = colIndex_rhs(2) - colIndex_rhs(1) + 1
+
+ ! Calculate the column offset for lhs
+ offset_col_lhs = (jtimecompo - 1) * tcol_rhs
+
+ irow_lhs = offset_row_lhs + irow_rhs
+ colIndex_lhs = CSRMatrix_GetColIndex(obj=obj, irow=irow_lhs)
+
+ DO icol = 1, tcol_rhs
+ icol_rhs = colIndex_rhs(1) + icol - 1
+ icol_lhs = colIndex_lhs(1) + offset_col_lhs + icol - 1
+
+ obj%A(icol_lhs) = scale0 * VALUE%A(icol_rhs)
+ END DO
+END DO
+
+END PROCEDURE obj_SetToSTMatrix1
+
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/ConvectiveMatrix_Method@Methods.F90 b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90
index 838cc5b12..2cefe0534 100644
--- a/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90
+++ b/src/submodules/ConvectiveMatrix/src/ConvectiveMatrix_Method@Methods.F90
@@ -19,114 +19,143 @@
IMPLICIT NONE
CONTAINS
-#include "./CM_1.inc"
-#include "./CM_2.inc"
-#include "./CM_3.inc"
-#include "./CM_4.inc"
-#include "./CM_5.inc"
-#include "./CM_6.inc"
-#include "./CM_7.inc"
-#include "./CM_8.inc"
-#include "./CM_9.inc"
-#include "./CM_10.inc"
+#include "./include/CM_1.F90"
+#include "./include/CM_2.F90"
+#include "./include/CM_3.F90"
+#include "./include/CM_4.F90"
+#include "./include/CM_5.F90"
+#include "./include/CM_6.F90"
+#include "./include/CM_7.F90"
+#include "./include/CM_8.F90"
+#include "./include/CM_9.F90"
+#include "./include/CM_10.F90"
!----------------------------------------------------------------------------
! ConvectiveMatrix
!----------------------------------------------------------------------------
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,446 @@
!
!----------------------------------------------------------------------------
+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, ans=p, c=c, nrow=ii, ncol=jj, &
+ crank=TypeFEVariableVector)
+
+ 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, ans=p, c=c, nrow=ii, ncol=jj, &
+ crank=TypeFEVariableVector)
+
+ 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, ans=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, ans=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, ans=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, ans=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
+
+ ! internal variables
+ 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/ConvectiveMatrix/src/CM_1.inc b/src/submodules/ConvectiveMatrix/src/include/CM_1.F90
similarity index 96%
rename from src/submodules/ConvectiveMatrix/src/CM_1.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_1.F90
index b72de1350..3500b3885 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_1.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_1.F90
@@ -46,7 +46,7 @@ PURE SUBROUTINE CM_1(ans, test, trial, c, term1, term2, opt)
!!
!! projection on trial
!!
- CALL GetProjectionOfdNdXt(obj=trial, cdNdXt=p, val=c)
+ CALL GetProjectionOfdNdXt(obj=trial, ans=p, c=c, crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(trial%N, 2)
ans = ans + outerprod(a=test%N(:, ips), &
diff --git a/src/submodules/ConvectiveMatrix/src/CM_10.inc b/src/submodules/ConvectiveMatrix/src/include/CM_10.F90
similarity index 97%
rename from src/submodules/ConvectiveMatrix/src/CM_10.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_10.F90
index 8d647f718..d3a880c66 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_10.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_10.F90
@@ -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_2.inc b/src/submodules/ConvectiveMatrix/src/include/CM_2.F90
similarity index 93%
rename from src/submodules/ConvectiveMatrix/src/CM_2.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_2.F90
index 345c2a243..a6fe2f259 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_2.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_2.F90
@@ -29,7 +29,7 @@ PURE SUBROUTINE CM_2(ans, test, trial, c, term1, term2, opt)
!!
!! projection on test
!!
- CALL GetProjectionOfdNdXt(obj=test, cdNdXt=p, val=c)
+ CALL GetProjectionOfdNdXt(obj=test, ans=p, c=c, crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
ans = ans + outerprod(a=p(:, ips), &
diff --git a/src/submodules/ConvectiveMatrix/src/CM_3.inc b/src/submodules/ConvectiveMatrix/src/include/CM_3.F90
similarity index 95%
rename from src/submodules/ConvectiveMatrix/src/CM_3.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_3.F90
index 4095c3ac6..e6f7207a5 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_3.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_3.F90
@@ -26,7 +26,7 @@ PURE SUBROUTINE CM_3(ans, test, trial, term1, term2, c, opt)
!!
CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
!!
- CALL GetInterpolation(obj=trial, val=c, interpol=realval)
+ CALL GetInterpolation(obj=trial, val=c, ans=realval)
!!
realval = trial%js * trial%ws * trial%thickness * realval
!!
diff --git a/src/submodules/ConvectiveMatrix/src/CM_4.inc b/src/submodules/ConvectiveMatrix/src/include/CM_4.F90
similarity index 95%
rename from src/submodules/ConvectiveMatrix/src/CM_4.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_4.F90
index 91c1be600..5dfd5daf9 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_4.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_4.F90
@@ -25,7 +25,7 @@ PURE SUBROUTINE CM_4(ans, test, trial, term1, term2, c, opt)
!!
CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
!!
- CALL GetInterpolation(obj=trial, val=c, interpol=realval)
+ CALL GetInterpolation(obj=trial, val=c, ans=realval)
!!
realval = trial%js * trial%ws * trial%thickness * realval
!!
diff --git a/src/submodules/ConvectiveMatrix/src/CM_5.inc b/src/submodules/ConvectiveMatrix/src/include/CM_5.F90
similarity index 95%
rename from src/submodules/ConvectiveMatrix/src/CM_5.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_5.F90
index a4cfc20a8..987058f70 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_5.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_5.F90
@@ -41,7 +41,7 @@ PURE SUBROUTINE CM_5(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, val=c, interpol=realval)
+ CALL GetInterpolation(obj=trial, val=c, ans=realval)
!!
realval = trial%js * trial%ws * trial%thickness * realval
!!
@@ -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/include/CM_6.F90
similarity index 95%
rename from src/submodules/ConvectiveMatrix/src/CM_6.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_6.F90
index 06cfb876f..82afeb95c 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_6.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_6.F90
@@ -41,7 +41,7 @@ PURE SUBROUTINE CM_6(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, val=c, interpol=realval)
+ CALL GetInterpolation(obj=trial, val=c, ans=realval)
!!
realval = trial%js * trial%ws * trial%thickness * realval
!!
@@ -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_7.inc b/src/submodules/ConvectiveMatrix/src/include/CM_7.F90
similarity index 100%
rename from src/submodules/ConvectiveMatrix/src/CM_7.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_7.F90
diff --git a/src/submodules/ConvectiveMatrix/src/CM_8.inc b/src/submodules/ConvectiveMatrix/src/include/CM_8.F90
similarity index 100%
rename from src/submodules/ConvectiveMatrix/src/CM_8.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_8.F90
diff --git a/src/submodules/ConvectiveMatrix/src/CM_9.inc b/src/submodules/ConvectiveMatrix/src/include/CM_9.F90
similarity index 97%
rename from src/submodules/ConvectiveMatrix/src/CM_9.inc
rename to src/submodules/ConvectiveMatrix/src/include/CM_9.F90
index d7cb134f9..02d011979 100644
--- a/src/submodules/ConvectiveMatrix/src/CM_9.inc
+++ b/src/submodules/ConvectiveMatrix/src/include/CM_9.F90
@@ -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/DOF/src/DOF_AddMethods@Methods.F90 b/src/submodules/DOF/src/DOF_AddMethods@Methods.F90
index 8f48dc16c..554acf4bc 100644
--- a/src/submodules/DOF/src/DOF_AddMethods@Methods.F90
+++ b/src/submodules/DOF/src/DOF_AddMethods@Methods.F90
@@ -16,351 +16,415 @@
!
SUBMODULE(DOF_AddMethods) Methods
-USE BaseMethod
+USE DOF_GetMethods, ONLY: GetNodeLoc, &
+ OPERATOR(.tdof.), &
+ GetNodeLoc_, &
+ GetIndex_, &
+ GetIDOF
+
+USE GlobalData, ONLY: NodesToDOF, DOFToNodes, NODES_FMT, DOF_FMT
+
+USE SafeSizeUtility, ONLY: SafeSize
+
+USE ReallocateUtility, ONLY: Reallocate
+
IMPLICIT NONE
+
+INTEGER(I4B), PARAMETER :: PARAM_EXPAND_FACTOR_TEMP_INTVEC = 2
+INTEGER(I4B), PARAMETER :: PARAM_TEMP_INTVEC_SIZE = 1024
+INTEGER(I4B) :: tempIntVec(PARAM_TEMP_INTVEC_SIZE)
+!$OMP THREADPRIVATE(tempIntVec)
+
+INTEGER(I4B), ALLOCATABLE :: tempAllocIntVec(:)
+!$OMP THREADPRIVATE(tempAllocIntVec)
+
CONTAINS
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add1
+MODULE PROCEDURE obj_Add1
INTEGER(I4B) :: tdof, idof, i, n, m
-!
+
tdof = .tdof.obj
n = SIZE(nodenum)
m = SIZE(VALUE)
-!
-!
+
SELECT CASE (obj%StorageFMT)
- !
- !
- !
+
CASE (DOF_FMT)
- !
- IF (m .NE. n) THEN
- ! vec( nodenum ) += scale * value( 1 )
- IF (m .EQ. 1) THEN
- !
- DO idof = 1, tdof
- vec(obj%valmap(idof) - 1 + nodenum) &
- & = vec(obj%valmap(idof) - 1 + nodenum) &
- & + scale * VALUE(1)
- END DO
- !
- ! Vec_dof_i( nodenum ) += scale * val_dof_i( : )
- ELSE IF (m .EQ. tdof * n) THEN
- !
- IF (Conversion(1) .EQ. nodesToDOF) THEN
- !
- DO idof = 1, tdof
- DO i = 1, n
- vec(obj%valmap(idof) - 1 + nodenum(i)) &
- & = vec(obj%valmap(idof) - 1 + nodenum(i)) &
- & + scale * VALUE((i - 1) * tdof + idof)
- END DO
- END DO
- !
- ELSE
- !
- DO idof = 1, tdof
- vec(obj%valmap(idof) - 1 + nodenum) &
- & = vec(obj%valmap(idof) - 1 + nodenum) &
- & + scale * VALUE((idof - 1) * n + 1:idof * n)
- END DO
- !
- END IF
- END IF
- !
- ELSE
- !
- DO idof = 1, tdof
- vec(obj%valmap(idof) - 1 + nodenum) &
- & = vec(obj%valmap(idof) - 1 + nodenum) &
- & + scale * VALUE(:)
+
+ IF (m .EQ. n) THEN
+
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+ vec(obj%valmap(idof) - 1 + nodenum(i)) = &
+ vec(obj%valmap(idof) - 1 + nodenum(i)) + scale * VALUE(i)
+ END DO
+
+ RETURN
+ END IF
+
+ ! vec( nodenum ) += scale * value( 1 )
+ IF (m .EQ. 1) THEN
+
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+ vec(obj%valmap(idof) - 1 + nodenum(i)) = &
+ vec(obj%valmap(idof) - 1 + nodenum(i)) + scale * VALUE(1)
+ END DO
+
+ RETURN
+ END IF
+
+ ! Vec_obj_i( nodenum ) += scale * val_obj_i( : )
+ ! IF (m .EQ. tdof * n) THEN
+ IF (conversion(1) .EQ. NodesToDOF) THEN
+
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+ vec(obj%valmap(idof) - 1 + nodenum(i)) = &
+ vec(obj%valmap(idof) - 1 + nodenum(i)) &
+ + scale * VALUE((i - 1) * tdof + idof)
END DO
- !
+
+ RETURN
+
END IF
- !
- !
- !
+
+ ! Vec_obj_i( nodenum ) += scale * val_obj_i( : )
+ ! IF (m .EQ. tdof * n) THEN
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+
+ vec(obj%valmap(idof) - 1 + nodenum(i)) = &
+ vec(obj%valmap(idof) - 1 + nodenum(i)) &
+ + scale * VALUE((idof - 1) * n + i)
+
+ END DO
+
+ RETURN
+
CASE (NODES_FMT)
- !
- IF (m .NE. n) THEN
- !
- IF (m .EQ. 1) THEN
- !
- DO idof = 1, tdof
- vec((nodenum - 1) * tdof + idof) &
- & = vec((nodenum - 1) * tdof + idof) &
- & + scale * VALUE(1)
- END DO
- !
- ELSE IF (m .EQ. tdof * n) THEN
- !
- IF (Conversion(1) .EQ. DOFToNodes) THEN
- !
- DO idof = 1, tdof
- DO i = 1, n
- vec((nodenum(i) - 1) * tdof + idof) &
- & = vec((nodenum(i) - 1) * tdof + idof) &
- & + scale * VALUE((idof - 1) * n + i)
- END DO
- END DO
- !
- ELSE
- !
- DO idof = 1, tdof
- DO i = 1, n
- vec((nodenum(i) - 1) * tdof + idof) &
- & = vec((nodenum(i) - 1) * tdof + idof) &
- & + scale * VALUE((i - 1) * tdof + idof)
- END DO
- END DO
- !
- END IF
- END IF
- !
- ELSE
- !
+
+ IF (m .EQ. n) THEN
+
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+
+ vec((nodenum(i) - 1) * tdof + idof) &
+ = vec((nodenum(i) - 1) * tdof + idof) &
+ + scale * VALUE(i)
+
+ END DO
+
+ RETURN
+
+ END IF
+
+ IF (m .EQ. 1) THEN
+
DO idof = 1, tdof
vec((nodenum - 1) * tdof + idof) &
& = vec((nodenum - 1) * tdof + idof) &
- & + scale * VALUE(:)
+ & + scale * VALUE(1)
+ END DO
+
+ RETURN
+ END IF
+
+ ! ELSE IF (m .EQ. tdof * n) THEN
+
+ IF (conversion(1) .EQ. DOFToNodes) THEN
+
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+
+ vec((nodenum(i) - 1) * tdof + idof) &
+ = vec((nodenum(i) - 1) * tdof + idof) &
+ + scale * VALUE((idof - 1) * n + i)
+
END DO
- !
+
+ RETURN
+
END IF
- !
+
+ DO CONCURRENT(idof=1:tdof, i=1:n)
+ vec((nodenum(i) - 1) * tdof + idof) &
+ = vec((nodenum(i) - 1) * tdof + idof) &
+ + scale * VALUE((i - 1) * tdof + idof)
+ END DO
+ RETURN
+
+ ! END IF
+
END SELECT
-!
-END PROCEDURE dof_add1
+
+END PROCEDURE obj_Add1
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add2
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-indx = getIndex(obj=obj, nodenum=nodenum)
-vec(indx) = vec(indx) + scale * VALUE
-DEALLOCATE (indx)
-END PROCEDURE dof_add2
+MODULE PROCEDURE obj_Add2
+INTEGER(I4B) :: tsize
+tsize = (.tdof.obj) * SIZE(nodenum)
+
+IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN
+
+ IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN
+ CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC)
+ END IF
+
+ CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, tsize=tsize)
+ CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, indx=tempAllocIntVec)
+
+ RETURN
+END IF
+
+CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempIntVec, tsize=tsize)
+CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+
+END PROCEDURE obj_Add2
!----------------------------------------------------------------------------
-! add
+! obj_add_help_1
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add3
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc( &
- & obj=obj,&
- & nodenum=nodenum,&
- & idof=idof)
-!
-IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN
- !
- vec(indx) = vec(indx) + scale * VALUE(:)
- !
-ELSE
- !
- vec(indx) = vec(indx) + scale * VALUE(1)
- !
-END IF
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add3
+PURE SUBROUTINE obj_add_help_1(vec, scale, VALUE, tsize, indx)
+ REAL(DFP), INTENT(INOUT) :: vec(:)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: VALUE
+ INTEGER(I4B), INTENT(IN) :: tsize
+ INTEGER(I4B), INTENT(IN) :: indx(:)
+
+ INTEGER(I4B) :: ii
+
+ DO CONCURRENT(ii=1:tsize)
+ vec(indx(ii)) = vec(indx(ii)) + scale * VALUE
+ END DO
+
+END SUBROUTINE obj_add_help_1
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add4
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc( &
- & obj=obj,&
- & nodenum=nodenum,&
- & idof=idof,&
- & ivar=ivar)
-!
-IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN
- vec(indx) = vec(indx) + scale * VALUE(:)
-ELSE
- vec(indx) = vec(indx) + scale * VALUE(1)
+MODULE PROCEDURE obj_Add3
+INTEGER(I4B) :: tsize
+
+tsize = SIZE(nodenum)
+
+IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN
+
+ IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN
+ CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC)
+ END IF
+
+ CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, &
+ tsize=tsize, idof=idof)
+
+ CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempAllocIntVec)
+
+ RETURN
END IF
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add4
+
+CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, &
+ tsize=tsize, idof=idof)
+CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+
+END PROCEDURE obj_Add3
!----------------------------------------------------------------------------
-! add
+! obj_add_help_2
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add5
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & ivar=ivar, &
- & spacecompo=spacecompo, &
- & timecompo=timecompo)
-!
-IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN
- vec(indx) = vec(indx) + scale * VALUE(:)
-ELSE
- vec(indx) = vec(indx) + scale * VALUE(1)
-END IF
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add5
+PURE SUBROUTINE obj_add_help_2(vec, scale, VALUE, tsize, indx)
+ REAL(DFP), INTENT(INOUT) :: vec(:)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: VALUE(:)
+ INTEGER(I4B), INTENT(IN) :: tsize
+ INTEGER(I4B), INTENT(IN) :: indx(:)
+
+ INTEGER(I4B) :: ii, n
+
+ n = SIZE(VALUE)
+
+ IF (n .EQ. 1) THEN
+
+ DO CONCURRENT(ii=1:tsize)
+ vec(indx(ii)) = vec(indx(ii)) + scale * VALUE(1)
+ END DO
+
+ RETURN
+
+ END IF
+
+ DO CONCURRENT(ii=1:tsize)
+ vec(indx(ii)) = vec(indx(ii)) + scale * VALUE(ii)
+ END DO
+
+END SUBROUTINE obj_add_help_2
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add6
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, &
- & spacecompo=spacecompo, timecompo=timecompo)
-!
-IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN
- vec(indx) = vec(indx) + scale * VALUE(:)
-ELSE
- vec(indx) = vec(indx) + scale * VALUE(1)
+MODULE PROCEDURE obj_Add4
+INTEGER(I4B) :: global_idof
+global_idof = GetIDOF(obj=obj, ivar=ivar, idof=idof)
+CALL obj_Add3(vec=vec, obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, &
+ idof=global_idof)
+END PROCEDURE obj_Add4
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add5
+INTEGER(I4B) :: global_idof
+global_idof = GetIDOF(obj=obj, ivar=ivar, spaceCompo=spaceCompo, &
+ timeCompo=timeCompo)
+CALL obj_Add3(vec=vec, obj=obj, nodenum=nodenum, VALUE=VALUE, scale=scale, &
+ idof=global_idof)
+END PROCEDURE obj_Add5
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add6
+INTEGER(I4B) :: tsize
+
+tsize = SIZE(nodenum)
+
+IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN
+
+ IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN
+ CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC)
+ END IF
+
+ CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, &
+ tsize=tsize, ivar=ivar, spacecompo=spacecompo, &
+ timecompo=timecompo)
+
+ CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempAllocIntVec)
+
+ RETURN
END IF
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add6
+
+CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, &
+ tsize=tsize, ivar=ivar, spacecompo=spacecompo, &
+ timecompo=timecompo)
+CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+
+END PROCEDURE obj_Add6
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add7
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & ivar=ivar, &
- & spacecompo=spacecompo, &
- & timecompo=timecompo)
-!
-IF (SIZE(nodenum) .EQ. SIZE(VALUE)) THEN
- vec(indx) = vec(indx) + scale * VALUE(:)
-ELSE
- vec(indx) = vec(indx) + scale * VALUE(1)
+MODULE PROCEDURE obj_Add7
+INTEGER(I4B) :: tsize
+
+tsize = SIZE(nodenum)
+
+IF (tsize .GT. PARAM_TEMP_INTVEC_SIZE) THEN
+
+ IF (tsize .GT. SafeSize(tempAllocIntVec)) THEN
+ CALL Reallocate(tempAllocIntVec, tsize * PARAM_EXPAND_FACTOR_TEMP_INTVEC)
+ END IF
+
+ CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempAllocIntVec, &
+ tsize=tsize, ivar=ivar, spacecompo=spacecompo, &
+ timecompo=timecompo)
+
+ CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempAllocIntVec)
+
+ RETURN
END IF
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add7
+
+CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ans=tempIntVec, &
+ tsize=tsize, ivar=ivar, spacecompo=spacecompo, &
+ timecompo=timecompo)
+CALL obj_add_help_2(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+
+END PROCEDURE obj_Add7
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add8
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-indx = getIndex(obj=obj, nodenum=nodenum)
-vec(indx) = vec(indx) + scale * VALUE
-DEALLOCATE (indx)
-END PROCEDURE dof_add8
+MODULE PROCEDURE obj_Add8
+INTEGER(I4B) :: tsize
+CALL GetIndex_(obj=obj, nodenum=nodenum, ans=tempIntVec, tsize=tsize)
+CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+END PROCEDURE obj_Add8
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add9
+MODULE PROCEDURE obj_Add9
INTEGER(I4B) :: indx
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & idof=idof)
-!
+indx = GetNodeLoc(obj=obj, nodenum=nodenum, idof=idof)
vec(indx) = vec(indx) + scale * VALUE
-END PROCEDURE dof_add9
+END PROCEDURE obj_Add9
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add10
+MODULE PROCEDURE obj_Add10
INTEGER(I4B) :: indx
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & ivar=ivar, &
- & idof=idof)
-!
+indx = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof)
vec(indx) = vec(indx) + scale * VALUE
-END PROCEDURE dof_add10
+END PROCEDURE obj_Add10
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add11
+MODULE PROCEDURE obj_Add11
INTEGER(I4B) :: indx
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & ivar=ivar, &
- & spacecompo=spacecompo, &
- & timecompo=timecompo)
-!
+indx = GetNodeLoc( obj=obj, nodenum=nodenum, ivar=ivar, spacecompo=spacecompo, &
+ timecompo=timecompo)
vec(indx) = vec(indx) + scale * VALUE
-END PROCEDURE dof_add11
+END PROCEDURE obj_Add11
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add12
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & ivar=ivar, &
- & spacecompo=spacecompo, &
- & timecompo=timecompo)
-!
-vec(indx) = vec(indx) + scale * VALUE
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add12
+MODULE PROCEDURE obj_Add12
+INTEGER(I4B) :: tsize
+
+CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, &
+ spacecompo=spacecompo, timecompo=timecompo, ans=tempIntVec, tsize=tsize)
+
+CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+
+END PROCEDURE obj_Add12
!----------------------------------------------------------------------------
-! add
+! Add
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_add13
-INTEGER(I4B), ALLOCATABLE :: indx(:)
-!
-indx = getNodeLoc( &
- & obj=obj, &
- & nodenum=nodenum, &
- & ivar=ivar, &
- & spacecompo=spacecompo, &
- & timecompo=timecompo)
-!
-vec(indx) = vec(indx) + scale * VALUE
-!
-DEALLOCATE (indx)
-!
-END PROCEDURE dof_add13
+MODULE PROCEDURE obj_Add13
+INTEGER(I4B) :: tsize
+
+CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, &
+ spacecompo=spacecompo, timecompo=timecompo, ans=tempIntVec, tsize=tsize)
+
+CALL obj_add_help_1(vec=vec, scale=scale, VALUE=VALUE, tsize=tsize, &
+ indx=tempIntVec)
+
+END PROCEDURE obj_Add13
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90 b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90
index bb9d331a4..fa76e9c91 100644
--- a/src/submodules/DOF/src/DOF_GetMethods@Methods.F90
+++ b/src/submodules/DOF/src/DOF_GetMethods@Methods.F90
@@ -364,7 +364,8 @@
MODULE PROCEDURE obj_GetNodeLoc2
INTEGER(I4B) :: tsize
-CALL obj_getnodeloc_2(obj, nodenum, idof, ans, tsize)
+CALL obj_GetNodeLoc_2(obj=obj, nodenum=nodenum, idof=idof, ans=ans, &
+ tsize=tsize)
END PROCEDURE obj_GetNodeLoc2
!----------------------------------------------------------------------------
@@ -386,7 +387,8 @@
MODULE PROCEDURE obj_GetNodeLoc3
INTEGER(I4B) :: tsize
-CALL obj_getnodeloc_3(obj, nodenum, idof, ans, tsize)
+CALL obj_GetNodeLoc_3(obj=obj, nodenum=nodenum, idof=idof, ans=ans, &
+ tsize=tsize)
END PROCEDURE obj_GetNodeLoc3
!----------------------------------------------------------------------------
@@ -408,9 +410,13 @@
MODULE PROCEDURE obj_GetNodeLoc4
IF (obj%storageFMT .EQ. NODES_FMT) THEN
- ans = [idof, .tnodes.obj, .tdof.obj]
+ ans(1) = idof
+ ans(2) = .tnodes.obj
+ ans(3) = .tdof.obj
ELSE
- ans = [obj%valmap(idof), obj%valmap(idof + 1) - 1, 1]
+ ans(1) = obj%valmap(idof)
+ ans(2) = obj%valmap(idof + 1) - 1
+ ans(3) = 1
END IF
END PROCEDURE obj_GetNodeLoc4
@@ -432,7 +438,8 @@
MODULE PROCEDURE obj_GetNodeLoc6
INTEGER(I4B) :: tsize
-CALL obj_GetNodeLoc_6(obj, nodenum, ivar, idof, ans, tsize)
+CALL obj_GetNodeLoc_6(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof, &
+ ans=ans, tsize=tsize)
END PROCEDURE obj_GetNodeLoc6
!----------------------------------------------------------------------------
@@ -459,10 +466,15 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc7
+INTEGER(I4B) :: idof, tspacecompo
+
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
+
ans = GetNodeLoc(obj=obj, nodenum=nodenum, ivar=ivar, &
- idof=GetIDOF(spacecompo=spacecompo, &
- timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
+
END PROCEDURE obj_GetNodeLoc7
!----------------------------------------------------------------------------
@@ -470,10 +482,13 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc8
-INTEGER(I4B) :: tsize
+INTEGER(I4B) :: tsize, idof, tspacecompo
+
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, &
- idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
END PROCEDURE obj_GetNodeLoc8
!----------------------------------------------------------------------------
@@ -481,9 +496,14 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc_8
+INTEGER(I4B) :: idof, tspacecompo
+
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
+
CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, &
- idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
END PROCEDURE obj_GetNodeLoc_8
!----------------------------------------------------------------------------
@@ -492,7 +512,8 @@
MODULE PROCEDURE obj_GetNodeLoc9
INTEGER(I4B) :: tsize
-CALL obj_GetNodeLoc_9(obj, nodenum, ivar, idof, ans, tsize)
+CALL obj_GetNodeLoc_9(obj=obj, nodenum=nodenum, ivar=ivar, idof=idof, &
+ ans=ans, tsize=tsize)
END PROCEDURE obj_GetNodeLoc9
!----------------------------------------------------------------------------
@@ -531,10 +552,14 @@
MODULE PROCEDURE obj_GetNodeLoc10
INTEGER(I4B) :: tsize
+INTEGER(I4B) :: idof(SIZE(timecompo)), tspacecompo
+
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
+
CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, &
- idof=GetIDOF(spacecompo=spacecompo, &
- timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
END PROCEDURE obj_GetNodeLoc10
!----------------------------------------------------------------------------
@@ -542,9 +567,12 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc_10
+INTEGER(I4B) :: idof(SIZE(timecompo)), tspacecompo
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, &
- idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
END PROCEDURE obj_GetNodeLoc_10
!----------------------------------------------------------------------------
@@ -553,9 +581,13 @@
MODULE PROCEDURE obj_GetNodeLoc11
INTEGER(I4B) :: tsize
+INTEGER(I4B) :: idof(SIZE(spacecompo)), tspacecompo
+
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, &
- idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
END PROCEDURE obj_GetNodeLoc11
!----------------------------------------------------------------------------
@@ -563,9 +595,13 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc_11
+INTEGER(I4B) :: idof(SIZE(spacecompo)), tspacecompo
+
+tspacecompo = obj.spacecomponents.ivar
+idof = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
+ tspacecompo=tspacecompo)
CALL GetNodeLoc_(obj=obj, nodenum=nodenum, ivar=ivar, ans=ans, tsize=tsize, &
- idof=GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar))
+ idof=idof)
END PROCEDURE obj_GetNodeLoc_11
!----------------------------------------------------------------------------
@@ -574,8 +610,9 @@
MODULE PROCEDURE obj_GetNodeLoc12
INTEGER(I4B) :: tsize
-CALL obj_GetNodeLoc_12(obj, nodenum, ivar, spacecompo, &
- timecompo, ans, tsize)
+CALL obj_GetNodeLoc_12(obj=obj, nodenum=nodenum, ivar=ivar, &
+ spacecompo=spacecompo, timecompo=timecompo, &
+ ans=ans, tsize=tsize)
END PROCEDURE obj_GetNodeLoc12
!----------------------------------------------------------------------------
@@ -583,14 +620,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc_12
-INTEGER(I4B) :: idofs(SIZE(timecompo)), ii, tempsize, tnode
+INTEGER(I4B) :: idofs(SIZE(timecompo))
+INTEGER(I4B) :: ii, tempsize, tnode, tspacecompo
tempsize = SIZE(timecompo)
tnode = SIZE(nodenum)
tsize = tempsize * tnode
+tspacecompo = obj.spacecomponents.ivar
idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar)
+ tspacecompo=tspacecompo)
tsize = 1
DO ii = 1, tnode
@@ -600,7 +639,6 @@
END DO
tsize = tsize - 1
-
END PROCEDURE obj_GetNodeLoc_12
!----------------------------------------------------------------------------
@@ -609,8 +647,9 @@
MODULE PROCEDURE obj_GetNodeLoc13
INTEGER(I4B) :: tsize
-CALL obj_GetNodeLoc_13(obj, nodenum, ivar, spacecompo, &
- timecompo, ans, tsize)
+CALL obj_GetNodeLoc_13(obj=obj, nodenum=nodenum, ivar=ivar, &
+ spacecompo=spacecompo, timecompo=timecompo, &
+ ans=ans, tsize=tsize)
END PROCEDURE obj_GetNodeLoc13
!----------------------------------------------------------------------------
@@ -618,14 +657,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetNodeLoc_13
-INTEGER(I4B) :: idofs(SIZE(spacecompo)), ii, tempsize, tnode
+INTEGER(I4B) :: idofs(SIZE(spacecompo))
+INTEGER(I4B) :: ii, tempsize, tnode, tspacecompo
tempsize = SIZE(spacecompo)
tnode = SIZE(nodenum)
tsize = tempsize * tnode
+tspacecompo = obj.spacecomponents.ivar
idofs = GetIDOF(spacecompo=spacecompo, timecompo=timecompo, &
- tspacecompo=obj.spacecomponents.ivar)
+ tspacecompo=tspacecompo)
tsize = 1
DO ii = 1, tnode
@@ -635,11 +676,10 @@
END DO
tsize = tsize - 1
-
END PROCEDURE obj_GetNodeLoc_13
!----------------------------------------------------------------------------
-! GetIndex
+! GetIndex
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetIndex1
@@ -651,7 +691,7 @@
END PROCEDURE obj_GetIndex1
!----------------------------------------------------------------------------
-! GetIndex_
+! GetIndex_
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetIndex_1
@@ -661,7 +701,7 @@
END PROCEDURE obj_GetIndex_1
!----------------------------------------------------------------------------
-! GetIndex
+! GetIndex
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetIndex2
@@ -673,7 +713,7 @@
END PROCEDURE obj_GetIndex2
!----------------------------------------------------------------------------
-! GetIndex_
+! GetIndex_
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetIndex_2
@@ -798,4 +838,30 @@
ans = GetIndex(obj=obj, ivar=NameToIndex(obj, varName), nodenum=nodenum)
END PROCEDURE obj_GetIndex6
+!----------------------------------------------------------------------------
+! GetNodeLoc_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetNodeLoc_14
+INTEGER(I4B) :: jj
+
+IF (storageFMT .EQ. NODES_FMT) THEN
+
+ ncol = SIZE(nodenum)
+ DO jj = 1, ncol
+ CALL GetNodeLoc_(obj=obj, nodenum=nodenum(jj), idof=idof, &
+ ans=ans(:, jj), tsize=nrow)
+ END DO
+
+ RETURN
+END IF
+
+ncol = SIZE(idof)
+DO jj = 1, ncol
+ CALL GetNodeLoc_(obj=obj, nodenum=nodenum, idof=idof(jj), &
+ ans=ans(:, jj), tsize=nrow)
+END DO
+
+END PROCEDURE obj_GetNodeLoc_14
+
END SUBMODULE Methods
diff --git a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90 b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90
index 5fda02d7e..7c7d17d14 100644
--- a/src/submodules/DOF/src/DOF_IOMethods@Methods.F90
+++ b/src/submodules/DOF/src/DOF_IOMethods@Methods.F90
@@ -20,7 +20,11 @@
! summary: This submodule contains IO method for [[DOF_]]
SUBMODULE(DOF_IOMethods) Methods
-USE BaseMethod
+USE Display_Method, ONLY: MyDisplay => Display
+USE Display_Method, ONLY: ToString
+USE DOF_Method, ONLY: OPERATOR(.tNames.)
+USE DOF_Method, ONLY: GetNodeLoc
+USE GlobalData, ONLY: FMT_DOF, FMT_NODES
IMPLICIT NONE
CONTAINS
@@ -30,65 +34,73 @@
MODULE PROCEDURE dof_Display1
INTEGER(I4B) :: n, j
+LOGICAL(LGT) :: isok
+
+CALL MyDisplay(msg, unitNo=unitNo)
+
+isok = ALLOCATED(obj%map)
+CALL MyDisplay(isok, "obj%map allocated: ", UnitNo=UnitNo)
+IF (.NOT. isok) RETURN
+
+n = SIZE(obj%map, 1) - 1
+CALL MyDisplay(n, "Total Physical Variables :", unitNo=unitNo)
+
+DO j = 1, n
+ CALL MyDisplay("Name : "//CHAR(obj%map(j, 1)), unitNo=unitNo)
+
+ IF (obj%map(j, 2) .LT. 0) THEN
+ CALL MyDisplay("Space Components : "//"Scalar", unitNo=unitNo)
+ ELSE
+ CALL MyDisplay(obj%map(j, 2), "Space Components : ", unitNo=unitNo)
+ END IF
+
+ CALL MyDisplay(obj%map(j, 3), "Time Components : ", unitNo=unitNo)
+ CALL MyDisplay(obj%map(j, 6), "Total Nodes : ", unitNo=unitNo)
+END DO
+
+SELECT CASE (obj%StorageFMT)
+CASE (FMT_DOF)
+ CALL MyDisplay("Storage Format : DOF", unitNo=unitNo)
+CASE (FMT_NODES)
+ CALL MyDisplay("Storage Format : Nodes", unitNo=unitNo)
+END SELECT
+
+CALL MyDisplay(obj%valmap, "Value map : ", unitNo=unitNo)
-IF (LEN_TRIM(msg) .NE. 0) THEN
- CALL Display("# "//TRIM(msg), unitNo=unitNo)
-END IF
-IF (ALLOCATED(obj%Map)) THEN
- ASSOCIATE (Map => obj%Map, ValMap => obj%ValMap)
- n = SIZE(Map, 1) - 1
- CALL Display(n, "# Total Physical Variables :", unitNo=unitNo)
- DO j = 1, n
- CALL Display("# Name : "//CHAR(Map(j, 1)), unitNo=unitNo)
- IF (Map(j, 2) .LT. 0) THEN
- CALL Display("# Space Components : "//"Scalar", unitNo=unitNo)
- ELSE
- CALL Display(Map(j, 2), "# Space Components : ", unitNo=unitNo)
- END IF
- CALL Display(Map(j, 3), "# Time Components : ", unitNo=unitNo)
- CALL Display(Map(j, 6), "# Total Nodes : ", unitNo=unitNo)
- END DO
- SELECT CASE (obj%StorageFMT)
- CASE (DOF_FMT)
- CALL Display("# Storage Format : DOF", unitNo=unitNo)
- CASE (Nodes_FMT)
- CALL Display("# Storage Format : Nodes", unitNo=unitNo)
- END SELECT
- CALL Display(obj%ValMap, "# Value Map : ", unitNo=unitNo)
- END ASSOCIATE
-ELSE
- CALL Display("# obj%Map : NOT ALLOCATED")
-END IF
END PROCEDURE dof_Display1
!----------------------------------------------------------------------------
! Display
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_display2
+MODULE PROCEDURE dof_Display2
INTEGER(I4B) :: jj, tnames, idof, a(3)
!> main
-CALL Display(obj, '# DOF data : ', unitNo=unitNo)
+CALL Display(obj, 'DOF data : ', unitNo=unitNo)
+
tnames = .tNames.obj
+
DO jj = 1, tnames
- CALL Display(ACHAR(obj%Map(jj, 1)), "# VAR : ", unitNo)
+ CALL MyDisplay(ACHAR(obj%Map(jj, 1)), "VAR : ", unitNo)
+
DO idof = obj%Map(jj, 5), obj%Map(jj + 1, 5) - 1
- a = getNodeLOC(obj=obj, idof=idof)
- CALL Display(Vec(a(1):a(2):a(3)), &
- & msg="DOF-"//TOSTRING(idof), unitNo=unitNo, advance="NO")
+ a = GetNodeLoc(obj=obj, idof=idof)
+ CALL MyDisplay( &
+ vec(a(1):a(2):a(3)), msg="DOF-"//ToString(idof), unitNo=unitNo, &
+ advance="NO", full=.TRUE.)
END DO
- CALL Display(" ", unitNo=unitNo, advance=.TRUE.)
+ CALL MyDisplay(" ", unitNo=unitNo, advance=.TRUE.)
END DO
-END PROCEDURE dof_display2
+END PROCEDURE dof_Display2
!----------------------------------------------------------------------------
! Display
!----------------------------------------------------------------------------
-MODULE PROCEDURE dof_display3
+MODULE PROCEDURE dof_Display3
IF (ALLOCATED(vec%val)) THEN
CALL Display(vec=vec%val, obj=obj, msg=msg, unitNo=unitNo)
END IF
-END PROCEDURE dof_display3
+END PROCEDURE dof_Display3
END SUBMODULE Methods
diff --git a/src/submodules/DiffusionMatrix/src/DM_1.inc b/src/submodules/DiffusionMatrix/src/DM_1.inc
index 9517abe0d..fb2e5bc73 100644
--- a/src/submodules/DiffusionMatrix/src/DM_1.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_1.inc
@@ -36,7 +36,7 @@ PURE SUBROUTINE DM_1(ans, test, trial, k, opt)
REAL(DFP), ALLOCATABLE :: realval(:), kbar(:)
INTEGER(I4B) :: ii
!! main
- CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
+ CALL getInterpolation(obj=trial, ans=kbar, val=k)
!!
realval = trial%js * trial%ws * trial%thickness * kbar
!!
diff --git a/src/submodules/DiffusionMatrix/src/DM_10.inc b/src/submodules/DiffusionMatrix/src/DM_10.inc
index 040bbf3c3..de1be138e 100644
--- a/src/submodules/DiffusionMatrix/src/DM_10.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_10.inc
@@ -36,8 +36,8 @@ PURE SUBROUTINE DM_10(ans, test, trial, c1, c2, opt)
TYPE(FEVariable_) :: k
INTEGER(I4B) :: ii
!! main
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=matbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c2bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=matbar, val=c2)
CALL Reallocate( c1bar, SIZE(matbar, 2), SIZE(matbar, 3))
!!
DO ii = 1, SIZE(c2bar, 2)
diff --git a/src/submodules/DiffusionMatrix/src/DM_3.inc b/src/submodules/DiffusionMatrix/src/DM_3.inc
index 5e67de895..40e78772f 100644
--- a/src/submodules/DiffusionMatrix/src/DM_3.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_3.inc
@@ -36,7 +36,7 @@ PURE SUBROUTINE DM_3(ans, test, trial, k, opt)
REAL(DFP), ALLOCATABLE :: realval(:)
INTEGER(I4B) :: ii
!! main
- CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
+ CALL getInterpolation(obj=trial, ans=kbar, val=k)
!!
realval = trial%js * trial%ws * trial%thickness
!!
diff --git a/src/submodules/DiffusionMatrix/src/DM_5.inc b/src/submodules/DiffusionMatrix/src/DM_5.inc
index 19137878e..0fdbcfdce 100644
--- a/src/submodules/DiffusionMatrix/src/DM_5.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_5.inc
@@ -41,9 +41,9 @@ PURE SUBROUTINE DM_5(ans, test, trial, c1, c2, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, Interpol=realval, val=c1)
+ CALL getInterpolation(obj=trial, ans=realval, val=c1)
!!
- CALL getInterpolation(obj=trial, Interpol=kbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=kbar, val=c2)
!!
realval = realval * trial%js * trial%ws * trial%thickness
!!
diff --git a/src/submodules/DiffusionMatrix/src/DM_6.inc b/src/submodules/DiffusionMatrix/src/DM_6.inc
index 1219d3a13..5ab22b8b3 100644
--- a/src/submodules/DiffusionMatrix/src/DM_6.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_6.inc
@@ -40,8 +40,8 @@ PURE SUBROUTINE DM_6(ans, test, trial, c1, c2, 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)
+ CALL getInterpolation(obj=trial, ans=cbar, val=c1)
+ CALL getInterpolation(obj=trial, ans=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)
diff --git a/src/submodules/DiffusionMatrix/src/DM_7.inc b/src/submodules/DiffusionMatrix/src/DM_7.inc
index 079844613..1fb143ef8 100644
--- a/src/submodules/DiffusionMatrix/src/DM_7.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_7.inc
@@ -41,7 +41,7 @@ PURE SUBROUTINE DM_7(ans, test, trial, c1, c2, opt)
!! 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)
+ CALL getInterpolation(obj=trial, ans=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)
diff --git a/src/submodules/DiffusionMatrix/src/DM_8.inc b/src/submodules/DiffusionMatrix/src/DM_8.inc
index 9fac7662e..6feb3670b 100644
--- a/src/submodules/DiffusionMatrix/src/DM_8.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_8.inc
@@ -39,9 +39,9 @@ PURE SUBROUTINE DM_8(ans, test, trial, c1, c2, opt)
REAL(DFP), ALLOCATABLE :: k1bar(:, :, :), k2bar(:, :, :), realval(:)
INTEGER(I4B) :: ii
!! main
- CALL getInterpolation(obj=trial, Interpol=k1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=k1bar, val=c1)
!!
- CALL getInterpolation(obj=trial, Interpol=k2bar, val=c2)
+ CALL getInterpolation(obj=trial, ans=k2bar, val=c2)
!!
realval = trial%js * trial%ws * trial%thickness
!!
diff --git a/src/submodules/DiffusionMatrix/src/DM_9.inc b/src/submodules/DiffusionMatrix/src/DM_9.inc
index c2367cc8d..86f91763f 100644
--- a/src/submodules/DiffusionMatrix/src/DM_9.inc
+++ b/src/submodules/DiffusionMatrix/src/DM_9.inc
@@ -36,8 +36,8 @@ PURE SUBROUTINE DM_9(ans, test, trial, c1, c2, opt)
TYPE(FEVariable_) :: k
INTEGER(I4B) :: ii
!! main
- CALL getInterpolation(obj=trial, interpol=matbar, val=c1)
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
+ CALL getInterpolation(obj=trial, ans=matbar, val=c1)
+ CALL getInterpolation(obj=trial, ans=c2bar, val=c2)
CALL Reallocate( c1bar, SIZE(matbar, 1), SIZE(matbar, 3))
!!
DO ii = 1, SIZE(c2bar, 2)
diff --git a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90 b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90
index 755daed8f..e877c2974 100644
--- a/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90
+++ b/src/submodules/DiffusionMatrix/src/DiffusionMatrix_Method@Methods.F90
@@ -25,186 +25,326 @@
!----------------------------------------------------------------------------
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, ans=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, ans=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, ans=c1bar, c=k, &
+ crank=TypeFEVariableVector)
+CALL getProjectionOfdNdXt(obj=trial, ans=c2bar, c=k, &
+ crank=TypeFEVariableVector)
+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, ans=c1bar, c=k, nrow=nrow, ncol=ii, &
+ crank=TypeFEVariableVector)
+CALL getProjectionOfdNdXt_(obj=trial, ans=c2bar, c=k, nrow=ncol, ncol=ii, &
+ crank=TypeFEVariableVector)
+
+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, ans=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, ans=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, ans=cbar, val=c1)
+CALL getInterpolation(obj=trial, ans=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, ans=cbar, val=c1, tsize=ii)
+CALL GetInterpolation_(obj=trial, ans=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, ans=c1bar, c=c2, &
+ crank=TypeFEVariableVector)
+CALL GetProjectionOfdNdXt(obj=trial, ans=c2bar, c=c2, &
+ crank=TypeFEVariableVector)
+
+CALL GetInterpolation(obj=trial, ans=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, ans=c1bar, c=c2, &
+ nrow=nrow, ncol=ii, crank=TypeFEVariableVector)
+CALL GetProjectionOfdNdXt_(obj=trial, ans=c2bar, c=c2, &
+ nrow=ncol, ncol=ii, crank=TypeFEVariableVector)
+CALL GetInterpolation_(obj=trial, ans=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, ans=realval, val=c1)
+CALL GetInterpolation(obj=trial, ans=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 +352,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 +367,20 @@
!----------------------------------------------------------------------------
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, ans=c1bar, c=c1, &
+ crank=TypeFEVariableVector)
+CALL getProjectionOfdNdXt(obj=trial, ans=c2bar, c=c2, &
+ crank=TypeFEVariableVector)
+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 +388,30 @@
!----------------------------------------------------------------------------
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, ans=c2bar, val=c1)
+CALL getInterpolation(obj=trial, ans=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, ans=c1bar, c=k, &
+ crank=TypeFEVariableVector)
+CALL getProjectionOfdNdXt(obj=trial, ans=c2bar, c=k, &
+ crank=TypeFEVariableVector)
+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 +419,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 +433,30 @@
!----------------------------------------------------------------------------
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, ans=matbar, val=c1)
+CALL getInterpolation(obj=trial, ans=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, ans=c1bar, c=k, &
+ crank=TypeFEVariableVector)
+CALL GetProjectionOfdNdXt(obj=trial, ans=c2bar, c=k, &
+ crank=TypeFEVariableVector)
+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 +464,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, ans=k1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=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 +485,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 +552,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 )
- CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
+ nsd = test%nsd
+ CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd)
+ CALL GetInterpolation(obj=trial, ans=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 )
- CALL getInterpolation(obj=trial, Interpol=kbar, val=k)
+ nsd = test%nsd
+ CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), nsd, nsd)
+ CALL GetInterpolation(obj=trial, ans=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..9dcba89fc 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix1.F90
@@ -27,11 +27,11 @@
MODULE PROCEDURE ElasticNitscheMatrix1a
REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:), evecBar(:, :)
-CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda)
-CALL getInterpolation(obj=trial, interpol=muBar, val=mu)
-CALL getInterpolation(obj=trial, interpol=evecBar, val=evec)
-ans = ElasticNitscheMatrix( &
-& test=test, trial=trial, lambda=lamBar, mu=muBar, evec=evecBar)
+CALL GetInterpolation(obj=trial, ans=lamBar, val=lambda)
+CALL GetInterpolation(obj=trial, ans=muBar, val=mu)
+CALL GetInterpolation(obj=trial, ans=evecBar, val=evec)
+ans = ElasticNitscheMatrix(test=test, trial=trial, lambda=lamBar, &
+ mu=muBar, evec=evecBar)
DEALLOCATE (lamBar, muBar, evecBar)
END PROCEDURE ElasticNitscheMatrix1a
@@ -41,7 +41,7 @@
MODULE PROCEDURE ElasticNitscheMatrix1b
REAL(DFP), ALLOCATABLE :: evecBar(:, :)
-CALL getInterpolation(obj=trial, interpol=evecBar, val=evec)
+CALL GetInterpolation(obj=trial, ans=evecBar, val=evec)
ans = ElasticNitscheMatrix( &
& test=test, &
& trial=trial, &
@@ -57,7 +57,7 @@
MODULE PROCEDURE ElasticNitscheMatrix1c
REAL(DFP), ALLOCATABLE :: evecBar(:, :)
-CALL getInterpolation(obj=trial, interpol=evecBar, val=evec)
+CALL getInterpolation(obj=trial, ans=evecBar, val=evec)
ans = ElasticNitscheMatrix(test=test, trial=trial, &
& lambda=lambda, mu=mu, evec=evecBar)
DEALLOCATE (evecBar)
@@ -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))
@@ -298,10 +298,10 @@
MODULE PROCEDURE ElasticNitscheMatrix1j
REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:)
-CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda)
-CALL getInterpolation(obj=trial, interpol=muBar, val=mu)
-ans = ElasticNitscheMatrix( &
-& test=test, trial=trial, lambda=lamBar, mu=muBar, dim=dim)
+CALL GetInterpolation(obj=trial, ans=lamBar, val=lambda)
+CALL GetInterpolation(obj=trial, ans=muBar, val=mu)
+ans = ElasticNitscheMatrix(test=test, trial=trial, lambda=lamBar, &
+ mu=muBar, dim=dim)
DEALLOCATE (lamBar, muBar)
END PROCEDURE ElasticNitscheMatrix1j
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..73845954c 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@Matrix3.F90
@@ -27,8 +27,8 @@
MODULE PROCEDURE ElasticNitscheMatrix3a
REAL(DFP), ALLOCATABLE :: alphaBar(:), evecBar(:, :)
-CALL getInterpolation(obj=trial, interpol=alphaBar, val=alpha)
-CALL getInterpolation(obj=trial, interpol=evecBar, val=evec)
+CALL GetInterpolation(obj=trial, ans=alphaBar, val=alpha)
+CALL GetInterpolation(obj=trial, ans=evecBar, val=evec)
ans = ElasticNitscheMatrix( &
& test=test, trial=trial, alpha=alphaBar, evec=evecBar)
DEALLOCATE (alphaBar, evecBar)
@@ -40,7 +40,7 @@
MODULE PROCEDURE ElasticNitscheMatrix3b
REAL(DFP), ALLOCATABLE :: evecBar(:, :)
-CALL getInterpolation(obj=trial, interpol=evecBar, val=evec)
+CALL getInterpolation(obj=trial, ans=evecBar, val=evec)
ans = ElasticNitscheMatrix( &
& test=test, trial=trial, alpha=alpha, evec=evecBar)
DEALLOCATE (evecBar)
@@ -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
@@ -175,9 +175,8 @@
MODULE PROCEDURE ElasticNitscheMatrix3f
REAL(DFP), ALLOCATABLE :: alphaBar(:)
-CALL getInterpolation(obj=trial, interpol=alphaBar, val=alpha)
-ans = ElasticNitscheMatrix( &
-& test=test, trial=trial, alpha=alphaBar, dim=dim)
+CALL GetInterpolation(obj=trial, ans=alphaBar, val=alpha)
+ans = ElasticNitscheMatrix(test=test, trial=trial, alpha=alphaBar, dim=dim)
DEALLOCATE (alphaBar)
END PROCEDURE ElasticNitscheMatrix3f
@@ -191,7 +190,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 +216,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..3fc5a008f 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))
@@ -123,8 +123,8 @@
MODULE PROCEDURE ElasticNitscheMatrixNormal1c
REAL(DFP), ALLOCATABLE :: lamBar(:), muBar(:)
-CALL getInterpolation(obj=trial, interpol=lamBar, val=lambda)
-CALL getInterpolation(obj=trial, interpol=muBar, val=mu)
+CALL GetInterpolation(obj=trial, ans=lamBar, val=lambda)
+CALL GetInterpolation(obj=trial, ans=muBar, val=mu)
ans = ElasticNitscheMatrixNormal( &
& test=test, trial=trial, lambda=lamBar, mu=muBar)
DEALLOCATE (lamBar, muBar)
diff --git a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90 b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90
index 677cb68ab..ab0021934 100644
--- a/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90
+++ b/src/submodules/ElasticNitscheMatrix/src/ElasticNitscheMatrix_Method@MatrixTangent.F90
@@ -119,7 +119,7 @@
!
! MODULE PROCEDURE ElasticNitscheMatrixTangent1c
! REAL(DFP), ALLOCATABLE :: muBar(:)
-! CALL getInterpolation(obj=trial, interpol=muBar, val=mu)
+! CALL getInterpolation(obj=trial, ans=muBar, val=mu)
! ans = ElasticNitscheMatrixTangent( &
! & test=test, trial=trial, mu=muBar)
! DEALLOCATE (muBar)
diff --git a/src/submodules/ElemshapeData/CMakeLists.txt b/src/submodules/ElemshapeData/CMakeLists.txt
index ca148d457..113ff1297 100644
--- a/src/submodules/ElemshapeData/CMakeLists.txt
+++ b/src/submodules/ElemshapeData/CMakeLists.txt
@@ -1,63 +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_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_ScalarInterpolMethods@Methods.F90
+ ${src_path}/ElemshapeData_VectorInterpolMethods@Methods.F90
+ ${src_path}/ElemshapeData_MatrixInterpolMethods@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..b442e106f 100755
--- a/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_ConstructorMethods@Methods.F90
@@ -20,7 +20,11 @@
! summary: Constructor method for ElemshapeData_ and STElemshapeData_
SUBMODULE(ElemshapeData_ConstructorMethods) Methods
-USE BaseMethod
+USE GlobalData, ONLY: stderr
+USE ReallocateUtility, ONLY: Reallocate
+USE QuadraturePoint_Method, ONLY: GetQuadraturePoints
+USE ErrorHandling, ONLY: Errormsg
+
IMPLICIT NONE
CONTAINS
@@ -28,332 +32,186 @@
! Initiate
!----------------------------------------------------------------------------
-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)
-END PROCEDURE elemsd_Allocate
+MODULE PROCEDURE obj_Allocate
+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 (.NOT. isok) RETURN
+
+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 PROCEDURE obj_Allocate
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_Initiate1
-
-CALL ErrorMSG( &
- & Msg="[WORK IN PROGRESS]", &
- & File=__FILE__, &
- & Routine="elemsd_Initiate1()", &
- & Line=__LINE__, &
- & UnitNo=stdout)
+MODULE PROCEDURE obj_Initiate1
+CALL ErrorMSG(msg="[WORK IN PROGRESS]", file=__FILE__, &
+ routine="obj_Initiate1()", line=__LINE__, unitno=stderr)
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
+END PROCEDURE obj_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 obj_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 obj_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
-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
+ 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
+
+END PROCEDURE obj_Initiate2
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE stsd_initiate
-INTEGER(I4B) :: tip, ip
-REAL(DFP) :: x(3)
+MODULE PROCEDURE obj_Initiate3
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tip, ip, nnt, tsize
+
+tip = elemsd%nips
+
+isok = ALLOCATED(obj)
+IF (isok) THEN
+ tsize = SIZE(obj)
-tip = SIZE(elemsd%N, 2)
-IF (ALLOCATED(obj)) THEN
- DO ip = 1, SIZE(obj)
+ DO ip = 1, tsize
CALL DEALLOCATE (obj(ip))
END DO
+
DEALLOCATE (obj)
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 obj_Initiate3
!----------------------------------------------------------------------------
! Deallocate
!----------------------------------------------------------------------------
-MODULE PROCEDURE elemsd_Deallocate
-IF (ALLOCATED(obj%Normal)) DEALLOCATE (obj%Normal)
+MODULE PROCEDURE obj_Deallocate
+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)
IF (ALLOCATED(obj%dNTdXt)) DEALLOCATE (obj%dNTdXt)
END SELECT
-END PROCEDURE elemsd_Deallocate
+END PROCEDURE obj_Deallocate
!----------------------------------------------------------------------------
!
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_HRGNParamMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90
index 97ba604d5..deb176da3 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_HRGNParamMethods@Methods.F90
@@ -53,7 +53,8 @@ PURE SUBROUTINE elemsd_getHRGNParam_a(obj, h, val, opt)
!!
!! Call get projection of dNdXt in q
!!
- CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar)
+ CALL GetProjectionOfdNdXt(obj=obj, ans=q, c=rvar, &
+ crank=TypeFEVariableVector)
!!
!! Calculate hmin and hmax
!!
@@ -108,7 +109,8 @@ PURE SUBROUTINE elemsd_getHRGNParam_b(obj, h, val, opt)
!!
!! Get Projection of dNTdXt in q
!!
- CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar)
+ CALL GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, &
+ crank=TypeFEVariableVector)
!!
!! Calculate hmin and hmax
!!
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..94b39a313
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_Hierarchical@Methods.F90
@@ -0,0 +1,179 @@
+! 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 ErrorHandling, ONLY: Errormsg
+USE GlobalData, ONLY: stderr
+
+USE InputUtility, ONLY: Input
+
+USE ReferenceElement_Method, ONLY: Refelem_Initiate => Initiate, &
+ Refelem_GetFaceElemType => GetFaceElemType, &
+ Refelem_RefCoord_ => RefCoord_
+
+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
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = "ElemshapeData_Hierarchical@Methods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! ElemshapeData_InitiateHierarchical
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalElemShapeData1
+REAL(DFP), ALLOCATABLE :: temp(:, :, :)
+INTEGER(I4B) :: 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 HierarchicalElemShapeData( &
+ 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 HierarchicalElemShapeData( &
+ obj=obj, quad=quad, refelem=refelem, cellOrder=cellOrder, &
+ faceOrder=faceOrder, edgeOrder=edgeOrder, cellOrient=cellOrient, &
+ faceOrient=faceOrient, edgeOrient=edgeOrient)
+END PROCEDURE HierarchicalElemShapeData3
+
+!----------------------------------------------------------------------------
+! HierarchicalFacetElemShapeData
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HierarchicalFacetElemShapeData1
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "HierarchicalFacetElemShapeData1()"
+#endif
+
+INTEGER(I4B) :: faceElemType, faceXidim, tFaceNodes, nrow, ncol
+REAL(DFP) :: faceRefelemCoord(3, 8)
+
+CALL HierarchicalElemShapeData(obj=obj, quad=quad, nsd=nsd, xidim=xidim, &
+ elemType=elemType, refelemCoord=refelemCoord, &
+ domainName=domainName, cellOrder=cellOrder, &
+ faceOrder=faceOrder, edgeOrder=edgeOrder, &
+ cellOrient=cellOrient, faceOrient=faceOrient, &
+ edgeOrient=edgeOrient)
+
+CALL Refelem_GetFaceElemType(elemType=elemType, &
+ localFaceNumber=localFaceNumber, &
+ faceElemType=faceElemType, &
+ opt=1, tFaceNodes=tFaceNodes)
+
+CALL Refelem_RefCoord_(elemType=faceElemType, refElem=domainName, &
+ ans=faceRefelemCoord, nrow=nrow, ncol=ncol)
+
+#ifdef DEBUG_VER
+CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "This is routine is under development")
+#endif
+
+faceXidim = xidim - 1
+CALL HierarchicalElemShapeData( &
+ obj=facetElemsd, quad=facetQuad, nsd=nsd, xidim=faceXidim, &
+ elemType=faceElemType, refelemCoord=faceRefelemCoord(1:nrow, 1:ncol), &
+ domainName=domainName, cellOrder=faceOrder(:, localFaceNumber))
+
+END PROCEDURE HierarchicalFacetElemShapeData1
+
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+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..9f10658b5 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_InterpolMethods@Methods.F90
@@ -16,579 +16,183 @@
!
SUBMODULE(ElemshapeData_InterpolMethods) Methods
-USE BaseMethod
+USE BaseType, ONLY: TypeFEVariableOpt
+USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_,&
+ FEVariableInitiate => Initiate, &
+ FEVariableGetRank => GetRank, &
+ FEVariableGetTotalShape => GetTotalShape, &
+ FEVariableSize => Size
+
IMPLICIT NONE
CONTAINS
!----------------------------------------------------------------------------
-! getinterpolation
+! GetInterpolation
!----------------------------------------------------------------------------
-MODULE PROCEDURE scalar_getinterpolation_1
-interpol = MATMUL(val, obj%N)
-END PROCEDURE scalar_getinterpolation_1
+MODULE PROCEDURE GetInterpolation1
+INTEGER(I4B) :: s(TypeFEVariableOpt%maxRank), totalShape, myrank, mylen
-!----------------------------------------------------------------------------
-! getSTinterpolation
-!----------------------------------------------------------------------------
+IF (ans%isInit) THEN
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val)
+ELSE
-MODULE PROCEDURE scalar_getinterpolation_2
-SELECT TYPE (obj)
-TYPE IS (STElemShapeData_)
- interpol = MATMUL(MATMUL(val, obj%T), obj%N)
-END SELECT
-END PROCEDURE scalar_getinterpolation_2
+ myrank = FEVariableGetRank(val)
+ totalShape = 0
-!----------------------------------------------------------------------------
-! getSTinterpolation
-!----------------------------------------------------------------------------
+ SELECT CASE (myrank)
+ CASE (TypeFEVariableOpt%scalar)
+ totalShape = 1
+ s(1) = obj%nips
+ mylen = s(1)
-MODULE PROCEDURE scalar_getinterpolation_3
-INTEGER(I4B) :: ipt
-CALL reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj))
-DO ipt = 1, SIZE(obj)
- interpol(:, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N)
-END DO
-END PROCEDURE scalar_getinterpolation_3
+ CASE (TypeFEVariableOpt%vector)
+ totalShape = 2
+ s(1) = FEVariableSize(val, 1)
+ s(2) = obj%nips
+ mylen = s(1) * s(2)
-!----------------------------------------------------------------------------
-! getinterpolation
-!----------------------------------------------------------------------------
+ CASE (TypeFEVariableOpt%matrix)
+ totalShape = 3
+ s(1) = FEVariableSize(val, 1)
+ s(2) = FEVariableSize(val, 2)
+ s(3) = obj%nips
+ mylen = s(1) * s(2) * s(3)
-MODULE PROCEDURE scalar_getinterpolation_4
-SELECT CASE (val%vartype)
-CASE (Constant)
- CALL Reallocate(interpol, SIZE(obj%N, 2))
- interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant)
-CASE (Space)
- IF (val%DefineOn .EQ. Nodal) THEN
- interpol = interpolation(obj, &
- & Get(val, TypeFEVariableScalar, TypeFEVariableSpace))
- ELSE
- interpol = Get(val, TypeFEVariableScalar, TypeFEVariableSpace)
- END IF
-CASE (SpaceTime)
- SELECT TYPE (obj)
- TYPE IS (STElemShapeData_)
- IF (val%DefineOn .EQ. Nodal) THEN
- interpol = STinterpolation(obj, &
- & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime))
- END IF
END SELECT
-END SELECT
-END PROCEDURE scalar_getinterpolation_4
-
-!----------------------------------------------------------------------------
-! getinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE scalar_getinterpolation_5
-INTEGER(I4B) :: ii
-! REAL(DFP), ALLOCATABLE :: m1(:)
-! !! main
-! CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj))
-! DO ii = 1, SIZE(obj)
-! CALL getInterpolation(obj=obj(ii), interpol=m1, val=val)
-! interpol(:, ii) = m1
-! END DO
-! DEALLOCATE (m1)
-CALL Reallocate(interpol, SIZE(obj(1)%N, 2), SIZE(obj))
-!!
-SELECT CASE (val%vartype)
-!!
-!!
-!!
-!!
-CASE (Constant)
- !!
- interpol = Get(val, TypeFEVariableScalar, TypeFEVariableConstant)
-!!
-!!
-!!
-!!
-CASE (Space)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- !!
- DO ii = 1, SIZE(obj)
- interpol(:, ii) = Interpolation(obj(ii), &
- & Get(val, TypeFEVariableScalar, TypeFEVariableSpace))
- END DO
- !!
- ELSE
- !!
- interpol(:, 1) = Get(val, TypeFEVariableScalar, TypeFEVariableSpace)
- !!
- DO ii = 2, SIZE(obj)
- interpol(:, ii) = interpol(:, 1)
- END DO
- !!
- END IF
-!!
-!!
-!!
-!!
-CASE (SpaceTime)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- !!
- DO ii = 1, SIZE(obj)
- interpol(:, ii) = STinterpolation(obj(ii), &
- & Get(val, TypeFEVariableScalar, TypeFEVariableSpaceTime))
- END DO
- !!
- ELSE
- interpol = Get(val, TypeFEVariableScalar, typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
-!!
-END PROCEDURE scalar_getinterpolation_5
-
-!---------------------------------------------------------------------------
-! getinterpolation
-!----------------------------------------------------------------------------
-MODULE PROCEDURE vector_getinterpolation_1
-interpol = MATMUL(val, obj%N)
-END PROCEDURE vector_getinterpolation_1
+ CALL FEVariableInitiate(obj=ans, &
+ s=s(1:totalShape), &
+ defineon=TypeFEVariableOpt%quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=FEVariableGetRank(val), &
+ len=mylen)
-!----------------------------------------------------------------------------
-! getSTinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE vector_getinterpolation_2
-SELECT TYPE (obj)
-TYPE IS (STElemShapeData_)
- interpol = MATMUL(MATMUL(val, obj%T), obj%N)
-END SELECT
-END PROCEDURE vector_getinterpolation_2
-
-!----------------------------------------------------------------------------
-! getSTinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE vector_getinterpolation_3
-INTEGER(I4B) :: ipt
-!!
-CALL reallocate(interpol, SIZE(val, 1), SIZE(obj(1)%N, 2), SIZE(obj))
-DO ipt = 1, SIZE(obj)
- interpol(:, :, ipt) = MATMUL(MATMUL(val, obj(ipt)%T), obj(ipt)%N)
-END DO
-END PROCEDURE vector_getinterpolation_3
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val)
+END IF
+END PROCEDURE GetInterpolation1
!----------------------------------------------------------------------------
-! getinterpolation
+! GetInterpolation_
!----------------------------------------------------------------------------
-MODULE PROCEDURE vector_getinterpolation_4
-REAL(DFP), ALLOCATABLE :: m1(:)
-INTEGER(I4B) :: ii
-!! main
-SELECT CASE (val%vartype)
-!!
-!! Constant
-!!
-CASE (Constant)
- !!
- m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant)
- CALL Reallocate(interpol, SIZE(m1), SIZE(obj%N, 2))
- DO ii = 1, SIZE(interpol, 2)
- interpol(:, ii) = m1
- END DO
- DEALLOCATE (m1)
-!!
-!! Space
-!!
-CASE (Space)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- interpol = interpolation(obj, &
- & Get(val, TypeFEVariableVector, TypeFEVariableSpace))
- ELSE
- interpol = Get(val, TypeFEVariableVector, TypeFEVariableSpace)
- END IF
-!!
-!! SpaceTime
-!!
-CASE (SpaceTime)
- !!
- SELECT TYPE (obj)
- TYPE IS (STElemShapeData_)
- interpol = STinterpolation(obj, &
- & Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime))
- END SELECT
-END SELECT
-!!
-!!
-!!
-END PROCEDURE vector_getinterpolation_4
+MODULE PROCEDURE GetInterpolation_1
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL, PARAMETER :: no = .FALSE.
-!----------------------------------------------------------------------------
-! getSTinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE vector_getinterpolation_5
-! INTEGER(I4B) :: ii
-! INTEGER(I4B), ALLOCATABLE :: s(:)
-! REAL(DFP), ALLOCATABLE :: m2(:, :)
-! !! main
-! s = SHAPE(val)
-! CALL Reallocate(interpol, s(1), SIZE(obj(1)%N, 2), SIZE(obj))
-! DO ii = 1, SIZE(obj)
-! CALL getInterpolation(obj=obj(ii), interpol=m2, val=val)
-! interpol(:, :, ii) = m2
-! END DO
-! DEALLOCATE (m2, s)
-!!
-REAL(DFP), ALLOCATABLE :: m1(:)
-INTEGER(I4B) :: ii, jj
-INTEGER(I4B), ALLOCATABLE :: s(:)
-!!
-!! main
-!!
-s = SHAPE(val)
-CALL Reallocate(interpol, s(1), SIZE(obj(1)%N, 2), SIZE(obj))
-!!
-SELECT CASE (val%vartype)
-!!
-!! Constant
-!!
-CASE (Constant)
- !!
- m1 = Get(val, TypeFEVariableVector, TypeFEVariableConstant)
- !!
- DO jj = 1, SIZE(interpol, 3)
- DO ii = 1, SIZE(interpol, 2)
- interpol(:, ii, jj) = m1
- END DO
- END DO
- DEALLOCATE (m1)
-!!
-!! Space
-!!
-CASE (Space)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- !!
- DO ii = 1, SIZE(obj)
- interpol(:, :, ii) = Interpolation(obj(ii), &
- & Get(val, TypeFEVariableVector, TypeFEVariableSpace))
- END DO
- !!
- ELSE
- !!
- interpol(:, :, 1) = Get(val, TypeFEVariableVector, TypeFEVariableSpace)
- !!
- DO ii = 2, SIZE(obj)
- interpol(:, :, ii) = interpol(:, :, 1)
- END DO
- !!
- END IF
-!!
-!! SpaceTime
-!!
-CASE (SpaceTime)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- !!
- DO ii = 1, SIZE(obj)
- interpol(:, :, ii) = STinterpolation(obj(ii), &
- & Get(val, TypeFEVariableVector, TypeFEVariableSpaceTime))
- END DO
- !!
- ELSE
- interpol = Get(val, TypeFEVariableVector, typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
-!!
-END PROCEDURE vector_getinterpolation_5
+CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, &
+ nips=obj%nips, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_1
!----------------------------------------------------------------------------
-! getinterpolation
+! GetInterpolation_
!----------------------------------------------------------------------------
-MODULE PROCEDURE matrix_getinterpolation_1
-interpol = MATMUL(val, obj%N)
-END PROCEDURE matrix_getinterpolation_1
+MODULE PROCEDURE GetInterpolation_1a
+INTEGER(I4B), PARAMETER :: timeIndx = 1
-!----------------------------------------------------------------------------
-! getSTinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE matrix_getinterpolation_2
SELECT TYPE (obj)
-TYPE IS (STElemShapeData_)
- interpol = MATMUL(MATMUL(val, obj%T), obj%N)
+TYPE IS (ElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, ans=ans, N=obj%N, nns=obj%nns, &
+ nips=obj%nips, scale=scale, &
+ addContribution=addContribution)
+CLASS IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, N=obj%N, nns=obj%nns, &
+ nips=obj%nips, T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ timeIndx=timeIndx, ans=ans)
END SELECT
-END PROCEDURE matrix_getinterpolation_2
+END PROCEDURE GetInterpolation_1a
!----------------------------------------------------------------------------
-! getSTinterpolation
+! GetInterpolation
!----------------------------------------------------------------------------
-MODULE PROCEDURE matrix_getinterpolation_3
-!! TODO
-END PROCEDURE matrix_getinterpolation_3
+MODULE PROCEDURE GetInterpolation2
+INTEGER(I4B) :: s(TypeFEVariableOpt%maxRank), totalShape, myrank, mylen, &
+ nipt
-!----------------------------------------------------------------------------
-! getinterpolation
-!----------------------------------------------------------------------------
+IF (ans%isInit) THEN
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val)
+ELSE
-MODULE PROCEDURE matrix_getinterpolation_4
-INTEGER(I4B) :: i
-INTEGER(I4B) :: s(2)
-!! main
-SELECT CASE (val%vartype)
-CASE (Constant)
- s(1:2) = SHAPE(val)
- CALL reallocate(interpol, s(1), s(2), SIZE(obj%N, 2))
- interpol(:, :, 1) = Get(val, TypeFEVariableMatrix, &
- & TypeFEVariableConstant)
- DO i = 2, SIZE(interpol, 3)
- interpol(:, :, i) = interpol(:, :, 1)
- END DO
-CASE (Space)
- IF (val%DefineOn .EQ. Nodal) THEN
- interpol = interpolation(obj, &
- & Get(val, TypeFEVariableMatrix, TypeFEVariableSpace))
- ELSE
- interpol = Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)
- END IF
-CASE (SpaceTime)
- SELECT TYPE (obj)
- TYPE IS (STElemShapeData_)
- IF (val%DefineOn .EQ. Nodal) THEN
- interpol = STinterpolation(obj, &
- & Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime))
- END IF
- END SELECT
-END SELECT
-END PROCEDURE matrix_getinterpolation_4
+ myrank = FEVariableGetRank(val)
+ totalShape = 0
+ nipt = SIZE(obj)
-!----------------------------------------------------------------------------
-! getinterpolation
-!----------------------------------------------------------------------------
+ SELECT CASE (myrank)
+ CASE (TypeFEVariableOpt%scalar)
-MODULE PROCEDURE matrix_getinterpolation_5
-! INTEGER(I4B) :: ii
-! INTEGER(I4B), ALLOCATABLE :: s(:)
-! REAL(DFP), ALLOCATABLE :: m3(:, :, :)
-! !! main
-! s = SHAPE(val)
-! CALL Reallocate(interpol, s(1), s(2), SIZE(obj(1)%N, 2), SIZE(obj))
-! DO ii = 1, SIZE(obj)
-! CALL getInterpolation(obj=obj(ii), interpol=m3, val=val)
-! interpol(:, :, :, ii) = m3
-! END DO
-! DEALLOCATE (m3, s)
-!!
-INTEGER(I4B) :: ii, jj
-INTEGER(I4B), ALLOCATABLE :: s(:)
-REAL(DFP), ALLOCATABLE :: m2(:, :)
-!!
-!! main
-!!
-s = SHAPE(val)
-CALL Reallocate(interpol, s(1), s(2), SIZE(obj(1)%N, 2), SIZE(obj))
-!!
-SELECT CASE (val%vartype)
-!!
-!!
-!!
-!!
-CASE (Constant)
- !!
- m2 = Get(val, TypeFEVariableMatrix, TypeFEVariableConstant)
- !!
- DO jj = 1, SIZE(interpol, 4)
- DO ii = 1, SIZE(interpol, 3)
- interpol(:, :, ii, jj) = m2
- END DO
- END DO
- !!
- DEALLOCATE (m2)
-!!
-!!
-!!
-!!
-CASE (Space)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- !!
- DO ii = 1, SIZE(obj)
- interpol(:, :, :, ii) = Interpolation(obj(ii), &
- & Get(val, TypeFEVariableMatrix, TypeFEVariableSpace))
- END DO
- !!
- ELSE
- !!
- interpol(:, :, :, 1) = Get(val, TypeFEVariableMatrix, TypeFEVariableSpace)
- !!
- DO ii = 2, SIZE(obj)
- interpol(:, :, :, ii) = interpol(:, :, :, 1)
- END DO
- !!
- END IF
-!!
-!!
-!!
-!!
-CASE (SpaceTime)
- !!
- IF (val%DefineOn .EQ. Nodal) THEN
- !!
- DO ii = 1, SIZE(obj)
- interpol(:, :, :, ii) = STinterpolation(obj(ii), &
- & Get(val, TypeFEVariableMatrix, TypeFEVariableSpaceTime))
- END DO
- !!
- ELSE
- interpol = Get(val, TypeFEVariableMatrix, typeFEVariableSpaceTime)
- END IF
-!!
-!!
-!!
-!!
-END SELECT
-!!
-END PROCEDURE matrix_getinterpolation_5
+ totalShape = 2
+ s(1) = obj(1)%nips
+ s(2) = nipt
+ mylen = s(1) * s(2)
-!----------------------------------------------------------------------------
-! getinterpolation
-!----------------------------------------------------------------------------
+ CASE (TypeFEVariableOpt%vector)
+ totalShape = 3
+ s(1) = FEVariableSize(val, 1)
+ s(2) = obj(1)%nips
+ s(3) = nipt
+ mylen = s(1) * s(2) * s(3)
-MODULE PROCEDURE master_getinterpolation_1
-REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), r3(:, :, :)
-!! main
-!!
-!! if val is a quadrature variable then do nothing
-!!
-IF (val%defineOn .EQ. Quadrature) THEN
- interpol = val
- RETURN
-END IF
-!!
-!! if val is a nodal variable then interpolate
-!!
-SELECT CASE (val%rank)
-CASE (Scalar)
- CALL getInterpolation(obj=obj, interpol=r1, val=val)
- interpol = QuadratureVariable(r1, typeFEVariableScalar, &
- & typeFEVariableSpace)
- DEALLOCATE (r1)
-CASE (Vector)
- CALL getInterpolation(obj=obj, interpol=r2, val=val)
- interpol = QuadratureVariable(r2, typeFEVariableVector, &
- & typeFEVariableSpace)
- DEALLOCATE (r2)
-CASE (Matrix)
- CALL getInterpolation(obj=obj, interpol=r3, val=val)
- interpol = QuadratureVariable(r3, typeFEVariableMatrix, &
- & typeFEVariableSpace)
- DEALLOCATE (r3)
-END SELECT
+ CASE (TypeFEVariableOpt%matrix)
+ totalShape = 4
+ s(1) = FEVariableSize(val, 1)
+ s(2) = FEVariableSize(val, 2)
+ s(3) = obj(1)%nips
+ s(4) = nipt
+ mylen = s(1) * s(2) * s(3) * s(4)
-END PROCEDURE master_getinterpolation_1
+ END SELECT
-!----------------------------------------------------------------------------
-! getInterpolation
-!----------------------------------------------------------------------------
+ CALL FEVariableInitiate(obj=ans, &
+ s=s(1:totalShape), &
+ defineon=TypeFEVariableOpt%quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=FEVariableGetRank(val), &
+ len=mylen)
-MODULE PROCEDURE master_getInterpolation_2
-REAL(DFP), ALLOCATABLE :: r2(:, :), r3(:, :, :), r4(:, :, :, :)
-!! main
-!!
-!! if val is a quadrature variable then do nothing
-!!
-IF (val%defineOn .EQ. Quadrature) THEN
- interpol = val
- RETURN
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val)
END IF
-!!
-!! if val is a nodal variable then interpolate
-!!
-SELECT CASE (val%rank)
-CASE (Scalar)
- CALL getInterpolation(obj=obj, interpol=r2, val=val)
- interpol = QuadratureVariable(r2, typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- DEALLOCATE (r2)
-CASE (Vector)
- CALL getInterpolation(obj=obj, interpol=r3, val=val)
- interpol = QuadratureVariable(r3, typeFEVariableVector, &
- & typeFEVariableSpaceTime)
- DEALLOCATE (r3)
-CASE (Matrix)
- CALL getInterpolation(obj=obj, interpol=r4, val=val)
- interpol = QuadratureVariable(r4, typeFEVariableMatrix, &
- & typeFEVariableSpaceTime)
- DEALLOCATE (r4)
-END SELECT
-!!
-END PROCEDURE master_getInterpolation_2
+END PROCEDURE GetInterpolation2
!----------------------------------------------------------------------------
-! interpolation
+! GetInterpolation_
!----------------------------------------------------------------------------
-MODULE PROCEDURE scalar_interpolation_1
-interpol = MATMUL(val, obj%N)
-END PROCEDURE scalar_interpolation_1
+MODULE PROCEDURE GetInterpolation_2
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL, PARAMETER :: no = .FALSE.
-!----------------------------------------------------------------------------
-! interpolationOfVector
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE vector_interpolation_1
-interpol = MATMUL(val, obj%N)
-END PROCEDURE vector_interpolation_1
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, scale=one, &
+ addContribution=no)
+END PROCEDURE GetInterpolation_2
!----------------------------------------------------------------------------
-! interpolationOfVector
+! GetInterpolation_
!----------------------------------------------------------------------------
-MODULE PROCEDURE matrix_interpolation_1
-interpol = MATMUL(val, obj%N)
-END PROCEDURE matrix_interpolation_1
+MODULE PROCEDURE GetInterpolation_2a
+INTEGER(I4B) :: aa, nipt
-!----------------------------------------------------------------------------
-! interpolationOfVector
-!----------------------------------------------------------------------------
+nipt = SIZE(obj)
-MODULE PROCEDURE master_interpolation_1
-CALL getInterpolation(obj=obj, val=val, interpol=ans)
-END PROCEDURE master_interpolation_1
-
-!----------------------------------------------------------------------------
-! STinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE scalar_stinterpolation_1
-interpol = MATMUL(MATMUL(val, obj%T), obj%N)
-END PROCEDURE scalar_stinterpolation_1
-
-!----------------------------------------------------------------------------
-! STinterpolation
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE vector_stinterpolation_1
-interpol = MATMUL(MATMUL(val, obj%T), obj%N)
-END PROCEDURE vector_stinterpolation_1
+DO aa = 1, nipt
+ CALL FEVariableGetInterpolation_(obj=val, N=obj(aa)%N, nns=obj(aa)%nns, &
+ nips=obj(aa)%nips, T=obj(aa)%T, &
+ nnt=obj(aa)%nnt, scale=scale, &
+ addContribution=addContribution, &
+ timeIndx=aa, ans=ans)
+END DO
+END PROCEDURE GetInterpolation_2a
!----------------------------------------------------------------------------
-! STinterpolation
+! interpolationOfVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE matrix_stinterpolation_1
-interpol = MATMUL(MATMUL(val, obj%T), obj%N)
-END PROCEDURE matrix_stinterpolation_1
+MODULE PROCEDURE Interpolation1
+CALL GetInterpolation(obj=obj, val=val, ans=ans)
+END PROCEDURE Interpolation1
END SUBMODULE Methods
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..3d8da941e
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_Lagrange@Methods.F90
@@ -0,0 +1,209 @@
+! 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, Refelem_GetFaceElemType => GetFaceElemType, &
+ Refelem_RefCoord_ => RefCoord_
+
+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 LagrangeElemShapeData(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 LagrangeElemShapeData(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
+
+!----------------------------------------------------------------------------
+! LagrangeFacetElemShapeData
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeFacetElemShapeData1
+INTEGER(I4B) :: faceElemType, faceXidim, tFaceNodes, nrow, ncol
+REAL(DFP) :: faceRefelemCoord(3, 8)
+
+CALL LagrangeElemShapeData(obj=obj, quad=quad, nsd=nsd, xidim=xidim, &
+ elemType=elemType, refelemCoord=refelemCoord, &
+ domainName=domainName, order=order, &
+ ipType=ipType, basisType=basisType, &
+ coeff=coeff, firstCall=firstCall, &
+ alpha=alpha, beta=beta, lambda=lambda)
+
+CALL Refelem_GetFaceElemType(elemType=elemType, localFaceNumber=localFaceNumber, &
+ faceElemType=faceElemType, &
+ opt=2, tFaceNodes=tFaceNodes)
+
+CALL Refelem_RefCoord_(elemType=faceElemType, refElem=domainName, &
+ ans=faceRefelemCoord, nrow=nrow, ncol=ncol)
+
+faceXidim = xidim - 1
+CALL LagrangeElemShapeData(obj=facetElemsd, quad=facetQuad, &
+ nsd=nsd, xidim=faceXidim, &
+ elemType=faceElemType, &
+ refelemCoord=faceRefelemCoord(1:nrow, 1:ncol), &
+ domainName=domainName, order=order, &
+ ipType=ipType, basisType=basisType, &
+ alpha=alpha, beta=beta, lambda=lambda)
+END PROCEDURE LagrangeFacetElemShapeData1
+
+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_MatrixInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90
new file mode 100644
index 000000000..a8f653f24
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_MatrixInterpolMethods@Methods.F90
@@ -0,0 +1,380 @@
+! 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_MatrixInterpolMethods) Methods
+USE ReallocateUtility, ONLY: Reallocate
+USE FEVariable_Method, ONLY: FEVariableSize => Size, &
+ FEVariableGetInterpolation_ => GetInterpolation_
+USE BaseType, ONLY: TypeFEVariableMatrix, TypeFEVariableConstant, &
+ TypeFEVariableSpace, TypeFEVariableSpaceTime, &
+ TypeFEVariableOpt
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! getinterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation1
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj%nips
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL GetInterpolation_(obj=obj, val=val, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_1
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj%nips
+CALL GetInterpolation_(obj=obj, val=val, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_1a
+INTEGER(I4B) :: ips, ii, valNNS, minNNS
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj%nips
+
+IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+valNNS = SIZE(val, 3)
+minNNS = MIN(valNNS, obj%nns)
+
+DO ips = 1, dim3
+ DO ii = 1, minNNS
+ ans(1:dim1, 1:dim2, ips) = ans(1:dim1, 1:dim2, ips) + &
+ scale * val(1:dim1, 1:dim2, ii) * obj%N(ii, ips)
+ END DO
+END DO
+END PROCEDURE GetInterpolation_1a
+
+!----------------------------------------------------------------------------
+! getSTinterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation2
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj%nips
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_2
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj%nips
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_2a
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+INTEGER(I4B) :: minNNT, valNNT, aa
+REAL(DFP) :: myscale
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj%nips
+
+valNNT = SIZE(val, 4)
+minNNT = MIN(valNNT, obj%nnt)
+
+IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+DO aa = 1, minNNT
+ myscale = obj%T(aa) * scale
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, :, :, aa), &
+ dim1=dim1, dim2=dim2, dim3=dim3, scale=myscale, &
+ addContribution=yes)
+END DO
+END PROCEDURE GetInterpolation_2a
+
+!----------------------------------------------------------------------------
+! getSTinterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation3
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj(1)%nips
+dim4 = SIZE(obj)
+
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation3
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_3
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+dim1 = SIZE(val, 1)
+dim2 = SIZE(val, 2)
+dim3 = obj(1)%nips
+dim4 = SIZE(obj)
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_3a
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_3a
+INTEGER(I4B) :: ipt
+
+dim1 = 0
+dim2 = 0
+dim3 = 0
+dim4 = SIZE(obj)
+
+DO ipt = 1, dim4
+ CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, :, ipt), &
+ val=val, dim1=dim1, dim2=dim2, dim3=dim3, &
+ scale=scale, addContribution=addContribution)
+END DO
+END PROCEDURE GetInterpolation_3a
+
+!----------------------------------------------------------------------------
+! getinterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation4
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = FEVariableSize(val, 1)
+dim2 = FEVariableSize(val, 2)
+dim3 = obj%nips
+
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation4
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_4
+
+!----------------------------------------------------------------------------
+! GetInterpolation_4a
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4a
+INTEGER(I4B) :: timeIndx0
+timeIndx0 = 1_I4B
+IF (PRESENT(timeIndx)) timeIndx0 = timeIndx
+
+SELECT CASE (val%vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableConstant, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpace, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+CASE (TypeFEVariableOpt%spacetime)
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, timeIndx=timeIndx0)
+
+ END SELECT
+
+END SELECT
+END PROCEDURE GetInterpolation_4a
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4b
+SELECT CASE (val%vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableConstant, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpace, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeFEVariableOpt%spacetime)
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+ END SELECT
+
+END SELECT
+END PROCEDURE GetInterpolation_4b
+
+!----------------------------------------------------------------------------
+! getinterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation5
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+dim1 = FEVariableSIZE(val, 1)
+dim2 = FEVariableSIZE(val, 2)
+dim3 = obj(1)%nips
+dim4 = SIZE(obj)
+
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation5
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_5
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_5
+
+!----------------------------------------------------------------------------
+! GetInterpolation_5a
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_5a
+INTEGER(I4B) :: ipt
+
+dim1 = 0
+dim2 = 0
+dim3 = 0
+dim4 = SIZE(obj)
+DO ipt = 1, dim4
+ CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, :, ipt), &
+ val=val, dim1=dim1, dim2=dim2, dim3=dim3, &
+ scale=scale, addContribution=addContribution, &
+ timeIndx=ipt)
+END DO
+END PROCEDURE GetInterpolation_5a
+
+!----------------------------------------------------------------------------
+! interpolationOfVector
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Interpolation1
+CALL GetInterpolation(obj=obj, val=val, ans=ans)
+END PROCEDURE Interpolation1
+
+!----------------------------------------------------------------------------
+! STinterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE STInterpolation1
+CALL GetInterpolation(obj=obj, val=val, ans=ans)
+END PROCEDURE STInterpolation1
+
+END SUBMODULE Methods
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..08eb339cf 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_ProjectionMethods@Methods.F90
@@ -16,149 +16,248 @@
!
SUBMODULE(ElemshapeData_ProjectionMethods) Methods
-USE BaseMethod
+USE FEVariable_Method, ONLY: GetInterpolation_
+USE ReallocateUtility, ONLY: Reallocate
+USE MatmulUtility, ONLY: Matmul_
+
IMPLICIT NONE
CONTAINS
!----------------------------------------------------------------------------
-! getProjectionOfdNdXt
+! GetProjectionOfdNdXt
!----------------------------------------------------------------------------
-MODULE PROCEDURE getProjectionOfdNdXt_1
- !! Define internal variables
+MODULE PROCEDURE GetProjectionOfdNdXt_1
+INTEGER(I4B) :: nrow, ncol
+
+nrow = obj%nns
+ncol = obj%nips
+CALL Reallocate(ans, nrow, ncol)
+
+CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, nrow=nrow, ncol=ncol)
+END PROCEDURE GetProjectionOfdNdXt_1
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNdXt_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNdXt1_
INTEGER(I4B) :: ii, nsd
- !!
- !! main
- !!
-CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3))
-nsd = SIZE(obj%dNdXt, 2)
-DO ii = 1, SIZE(cdNdXt, 2)
- cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), Val(1:nsd))
+
+nrow = obj%nns !!SIZE(obj%dNdXt, 1)
+ncol = obj%nips !!SIZE(obj%dNdXt, 3)
+nsd = obj%nsd !!SIZE(obj%dNdXt, 2)
+
+DO ii = 1, ncol
+ ans(1:nrow, ii) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ii), c(1:nsd))
END DO
- !!
-END PROCEDURE getProjectionOfdNdXt_1
+END PROCEDURE GetProjectionOfdNdXt1_
!----------------------------------------------------------------------------
-! getProjectionOfdNdXt
+! GetProjectionOfdNdXt
!----------------------------------------------------------------------------
-MODULE PROCEDURE getProjectionOfdNdXt_2
-INTEGER(I4B) :: ii, nsd
-REAL(DFP), ALLOCATABLE :: cbar(:, :)
- !!
- !! main
- !!
-CALL getInterpolation(obj=obj, val=val, interpol=cbar)
-CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3))
-nsd = SIZE(obj%dNdXt, 2)
-DO ii = 1, SIZE(cdNdXt, 2)
- cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), cbar(1:nsd, ii))
+MODULE PROCEDURE GetProjectionOfdNdXt_2
+INTEGER(I4B) :: nrow, ncol
+
+nrow = obj%nns
+ncol = obj%nips
+CALL Reallocate(ans, nrow, ncol)
+CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, crank=crank, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE GetProjectionOfdNdXt_2
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNdXt_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNdXt2_
+INTEGER(I4B) :: ips, nsd, i1
+! REAL(DFP) :: cbar(SIZE(obj%dNdXt, 2), SIZE(obj%dNdXt, 3))
+REAL(DFP) :: cbar(3), T(0)
+
+nrow = obj%nns
+ncol = obj%nips
+nsd = obj%nsd
+cbar = 0.0_DFP
+
+! USE FEVariable_Method, only: FEVariableGetInterpolation_ => GetInterpolation_
+DO ips = 1, obj%nips
+ CALL GetInterpolation_( &
+ obj=c, rank=crank, N=obj%N, nns=obj%nns, spaceIndx=ips, timeIndx=0_I4B, &
+ T=T, nnt=0_I4B, scale=1.0_DFP, addContribution=.FALSE., ans=cbar, &
+ tsize=i1)
+
+ ans(1:nrow, ips) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ips), cbar(1:nsd))
END DO
- !!
-DEALLOCATE (cbar)
- !!
-END PROCEDURE getProjectionOfdNdXt_2
+END PROCEDURE GetProjectionOfdNdXt2_
!----------------------------------------------------------------------------
! getProjectionOfdNdXt
!----------------------------------------------------------------------------
-MODULE PROCEDURE getProjectionOfdNdXt_3
- !! Define internal variables
-INTEGER(I4B) :: ii, nsd
- !!
- !! main
- !!
-CALL Reallocate(cdNdXt, SIZE(obj%dNdXt, 1), SIZE(obj%dNdXt, 3))
-nsd = SIZE(obj%dNdXt, 2)
-DO ii = 1, SIZE(cdNdXt, 2)
- cdNdXt(:, ii) = MATMUL(obj%dNdXt(:, :, ii), val(1:nsd, ii))
+MODULE PROCEDURE GetProjectionOfdNdXt_3
+INTEGER(I4B) :: nrow, ncol
+
+nrow = obj%nns
+ncol = obj%nips
+CALL Reallocate(ans, nrow, ncol)
+CALL GetProjectionOfdNdXt_(obj=obj, ans=ans, c=c, nrow=nrow, ncol=ncol)
+END PROCEDURE GetProjectionOfdNdXt_3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNdXt3_
+INTEGER(I4B) :: ips, nsd
+
+nrow = obj%nns
+ncol = obj%nips
+nsd = obj%nsd
+
+DO ips = 1, obj%nips
+ ans(1:nrow, ips) = MATMUL(obj%dNdXt(1:nrow, 1:nsd, ips), c(1:nsd, ips))
END DO
- !!
-END PROCEDURE getProjectionOfdNdXt_3
+END PROCEDURE GetProjectionOfdNdXt3_
!----------------------------------------------------------------------------
-! getProjectionOfdNTdXt
+! GetProjectionOfdNTdXt
!----------------------------------------------------------------------------
-MODULE PROCEDURE getProjectionOfdNTdXt_1
-INTEGER(I4B) :: ii, nsd
- !!
- !! main
- !!
-CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), &
- & SIZE(obj%dNTdXt, 4))
-nsd = SIZE(obj%dNTdXt, 3)
- !!
-DO ii = 1, SIZE(cdNTdXt, 3)
- cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), Val(1:nsd))
+MODULE PROCEDURE GetProjectionOfdNTdXt_1
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = obj%nns
+dim2 = obj%nnt
+dim3 = obj%nips
+
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL GetProjectionOfdNTdXt_(obj=obj, ans=ans, c=c, dim1=dim1, dim2=dim2, &
+ dim3=dim3)
+END PROCEDURE GetProjectionOfdNTdXt_1
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNTdXt1_
+INTEGER(I4B) :: ips, nsd, i1, i2
+
+dim1 = obj%nns
+dim2 = obj%nnt
+dim3 = obj%nips
+nsd = obj%nsd
+
+DO ips = 1, obj%nips
+ CALL Matmul_(a1=obj%dNTdXt(1:dim1, 1:dim2, 1:nsd, ips), &
+ a2=c(1:nsd), ans=ans(:, :, ips), nrow=i1, ncol=i2)
END DO
- !!
-END PROCEDURE getProjectionOfdNTdXt_1
+END PROCEDURE GetProjectionOfdNTdXt1_
!----------------------------------------------------------------------------
-! getProjectionOfdNTdXt
+! GetProjectionOfdNTdXt
!----------------------------------------------------------------------------
-MODULE PROCEDURE getProjectionOfdNTdXt_2
- !!
-INTEGER(I4B) :: ii, nsd
-REAL(DFP), ALLOCATABLE :: cbar(:, :)
- !!
- !! main
- !!
-CALL getInterpolation(obj=obj, val=val, interpol=cbar)
-CALL Reallocate(cdNTdXt, SIZE(obj%dNTdXt, 1), SIZE(obj%dNTdXt, 2), &
- & SIZE(obj%dNTdXt, 4))
-nsd = SIZE(obj%dNTdXt, 3)
- !!
-DO ii = 1, SIZE(cdNTdXt, 3)
- cdNTdXt(:, :, ii) = MATMUL(obj%dNTdXt(:, :, :, ii), cbar(1:nsd, ii))
+MODULE PROCEDURE GetProjectionOfdNTdXt_2
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = obj%nns
+dim2 = obj%nnt
+dim3 = obj%nips
+
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL GetProjectionOfdNTdXt_(obj=obj, ans=ans, c=c, crank=crank, &
+ dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE GetProjectionOfdNTdXt_2
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNTdXt2_
+INTEGER(I4B) :: ips, nsd, i1, i2
+REAL(DFP) :: cbar(3)
+
+dim1 = obj%nns
+dim2 = obj%nnt
+dim3 = obj%nips
+nsd = obj%nsd
+
+DO ips = 1, obj%nips
+ CALL GetInterpolation_( &
+ obj=c, rank=crank, N=obj%N, nns=obj%nns, spaceIndx=ips, timeIndx=1_I4B, &
+ T=obj%T, nnt=obj%nnt, scale=1.0_DFP, addContribution=.FALSE., ans=cbar, &
+ tsize=i1)
+
+ CALL Matmul_(a1=obj%dNTdXt(1:dim1, 1:dim2, 1:nsd, ips), &
+ a2=cbar(1:nsd), ans=ans(:, :, ips), nrow=i1, ncol=i2)
END DO
- !!
-DEALLOCATE (cbar)
-END PROCEDURE getProjectionOfdNTdXt_2
-
-!----------------------------------------------------------------------------
-! getProjectionOfdNTdXt
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE getProjectionOfdNTdXt_3
- !!
-INTEGER(I4B) :: ii, jj, nsd
-REAL(DFP), ALLOCATABLE :: cbar(:, :, :)
- !!
- !! main
- !!
-CALL getInterpolation(obj=obj, val=val, interpol=cbar)
- !!
-CALL Reallocate(cdNTdXt, &
- & SIZE(obj(1)%dNTdXt, 1), &
- & SIZE(obj(1)%dNTdXt, 2), &
- & SIZE(obj(1)%dNTdXt, 4), SIZE(obj))
- !!
-! CALL Reallocate( &
-! & cdNTdXt, &
-! & SIZE(obj(1)%N, 1), &
-! & SIZE(obj(1)%T), &
-! & SIZE(obj(1)%N, 2), &
-! & SIZE(obj) )
- !!
-nsd = SIZE(obj(1)%dNTdXt, 3)
- !!
-DO jj = 1, SIZE(cbar, 3)
- DO ii = 1, SIZE(cbar, 2)
- !!
- cdNTdXt(:, :, ii, jj) = MATMUL( &
- & obj(jj)%dNTdXt(:, :, :, ii), &
- & cbar(1:nsd, ii, jj))
- !!
+END PROCEDURE GetProjectionOfdNTdXt2_
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNTdXt_3
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+
+dim1 = obj(1)%nns
+dim2 = obj(1)%nnt
+dim3 = obj(1)%nips
+dim4 = SIZE(obj)
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL GetProjectionOfdNTdXt_(obj=obj, ans=ans, c=c, crank=crank, &
+ dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+END PROCEDURE GetProjectionOfdNTdXt_3
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNTdXt3_
+INTEGER(I4B) :: ips, ipt, nsd, i1, i2
+REAL(DFP) :: cbar(3)
+
+dim1 = obj(1)%nns
+dim2 = obj(1)%nnt
+dim3 = obj(1)%nips
+dim4 = SIZE(obj)
+nsd = obj(1)%nsd
+
+DO ipt = 1, dim4
+ DO ips = 1, obj(ipt)%nips
+ CALL GetInterpolation_( &
+ obj=c, rank=crank, N=obj(ipt)%N, nns=obj(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=obj(ipt)%T, nnt=obj(ipt)%nnt, &
+ scale=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1)
+
+ CALL Matmul_(a1=obj(ipt)%dNTdXt(1:dim1, 1:dim2, 1:nsd, ips), &
+ a2=cbar(1:nsd), ans=ans(:, :, ips, ipt), nrow=i1, ncol=i2)
END DO
END DO
- !!
-DEALLOCATE (cbar)
- !!
-END PROCEDURE getProjectionOfdNTdXt_3
+END PROCEDURE GetProjectionOfdNTdXt3_
+
+!----------------------------------------------------------------------------
+! GetProjectionOfdNTdXt_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetProjectionOfdNTdXt4_
+INTEGER(I4B) :: nsd, i1, i2
+REAL(DFP) :: cbar(3)
+
+nrow = obj(ips)%nns
+ncol = obj(ips)%nnt
+nsd = obj(ips)%nsd
+
+CALL GetInterpolation_( &
+ obj=c, rank=crank, N=obj(ipt)%N, nns=obj(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=obj(ipt)%T, nnt=obj(ipt)%nnt, &
+ scale=1.0_DFP, addContribution=.FALSE., ans=cbar, tsize=i1)
+
+CALL Matmul_(a1=obj(ipt)%dNTdXt(1:nrow, 1:ncol, 1:nsd, ips), &
+ a2=cbar(1:nsd), ans=ans, nrow=i1, ncol=i2)
+END PROCEDURE GetProjectionOfdNTdXt4_
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90
new file mode 100644
index 000000000..fb0c34c1d
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_ScalarInterpolMethods@Methods.F90
@@ -0,0 +1,318 @@
+! 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_ScalarInterpolMethods) Methods
+USE ReallocateUtility, ONLY: Reallocate
+USE BaseType, ONLY: TypeFEVariableOpt, TypeFEVariableScalar, &
+ TypeFEVariableConstant, TypeFEVariableSpace, &
+ TypeFEVariableSpaceTime
+USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation1
+INTEGER(I4B) :: tsize
+CALL Reallocate(ans, obj%nips)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, &
+ tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.)
+END PROCEDURE GetInterpolation1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_1
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, &
+ tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.)
+END PROCEDURE GetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_1a
+INTEGER(I4B) :: minNNS, valNNS, ips, ii
+
+tsize = obj%nips
+valNNS = SIZE(val)
+minNNS = MIN(valNNS, obj%nns)
+
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+
+!ans(1:obj%nips) = MATMUL(val(1:minNNS), obj%N(1:minNNS, 1:obj%nips))
+DO ips = 1, obj%nips
+ DO ii = 1, minNNS
+ ans(ips) = ans(ips) + scale * val(ii) * obj%N(ii, ips)
+ END DO
+END DO
+END PROCEDURE GetInterpolation_1a
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation2
+INTEGER(I4B) :: tsize
+CALL Reallocate(ans, obj%nips)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, &
+ tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.)
+END PROCEDURE GetInterpolation2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_2
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, &
+ tsize=tsize, scale=1.0_DFP, addContribution=.FALSE.)
+END PROCEDURE GetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_2a
+INTEGER(I4B) :: minNNT, valNNT, aa
+REAL(DFP) :: myscale
+
+tsize = 0 !! We will read tsize in the loop below
+valNNT = SIZE(val, 2)
+minNNT = MIN(valNNT, obj%nnt)
+
+IF (.NOT. addContribution) ans(1:obj%nips) = 0.0_DFP
+
+DO aa = 1, minNNT
+ myscale = obj%T(aa) * scale
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, aa), &
+ tsize=tsize, scale=myscale, addContribution=.TRUE.)
+END DO
+END PROCEDURE GetInterpolation_2a
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation3
+INTEGER(I4B) :: nrow, ncol
+
+nrow = obj(1)%nips
+ncol = SIZE(obj)
+CALL Reallocate(ans, nrow, ncol)
+CALL GetInterpolation_(obj=obj, ans=ans, &
+ val=val, nrow=nrow, ncol=ncol, scale=1.0_DFP, &
+ addContribution=.FALSE.)
+END PROCEDURE GetInterpolation3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_3
+CALL GetInterpolation_(obj=obj, ans=ans, &
+ val=val, nrow=nrow, ncol=ncol, scale=1.0_DFP, &
+ addContribution=.FALSE.)
+END PROCEDURE GetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_3a
+INTEGER(I4B) :: ipt
+
+nrow = 0 !! We will read nrow in the loop below
+ncol = SIZE(obj)
+
+DO ipt = 1, ncol
+ CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, ipt), &
+ val=val, tsize=nrow, scale=scale, &
+ addContribution=addContribution)
+END DO
+END PROCEDURE GetInterpolation_3a
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation4
+INTEGER(I4B) :: tsize
+CALL Reallocate(ans, obj%nips)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize)
+END PROCEDURE GetInterpolation4
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, tsize=tsize, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_4
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4a
+INTEGER(I4B) :: timeIndx0
+
+timeIndx0 = 1_I4B
+IF (PRESENT(timeIndx)) timeIndx0 = timeIndx
+
+SELECT CASE (val%vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableConstant, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, tsize=tsize)
+
+CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpace, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, tsize=tsize)
+
+CASE (TypeFEVariableOpt%spacetime)
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, tsize=tsize, &
+ timeIndx=timeIndx0)
+
+ END SELECT
+
+END SELECT
+END PROCEDURE GetInterpolation_4a
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4b
+SELECT CASE (val%vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableConstant, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans)
+
+CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpace, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans)
+
+CASE (TypeFEVariableOpt%spaceTime)
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans)
+
+ END SELECT
+END SELECT
+END PROCEDURE GetInterpolation_4b
+
+!----------------------------------------------------------------------------
+! GetInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation5
+INTEGER(I4B) :: nrow, ncol
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+nrow = obj(1)%nips
+ncol = SIZE(obj)
+CALL Reallocate(ans, nrow, ncol)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, &
+ ncol=ncol, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation5
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_5
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, &
+ ncol=ncol, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_5
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_5a
+INTEGER(I4B) :: ipt
+
+nrow = 0
+ncol = SIZE(obj)
+
+DO ipt = 1, ncol
+ CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, ipt), &
+ val=val, tsize=nrow, scale=scale, &
+ addContribution=addContribution, timeIndx=ipt)
+END DO
+END PROCEDURE GetInterpolation_5a
+
+!----------------------------------------------------------------------------
+! Interpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Interpolation1
+CALL GetInterpolation(obj=obj, ans=ans, val=val)
+END PROCEDURE Interpolation1
+
+!----------------------------------------------------------------------------
+! STInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE STInterpolation1
+CALL GetInterpolation(obj=obj, ans=ans, val=val)
+END PROCEDURE STInterpolation1
+
+END SUBMODULE Methods
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90
index 2353d3d0f..a56e93c53 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_SetMethods@Methods.F90
@@ -16,7 +16,11 @@
!
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 +30,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SetThickness
-obj%Thickness = MATMUL(val, N)
+obj%thickness(1:obj%nips) = MATMUL(val, N)
END PROCEDURE elemsd_SetThickness
!----------------------------------------------------------------------------
@@ -42,7 +46,11 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SetBarycentricCoord
-obj%Coord = MATMUL(val, N)
+INTEGER(I4B) :: valNNS
+
+valNNS = SIZE(val, 2)
+obj%coord(1:obj%nsd, 1:obj%nips) = MATMUL(val(1:obj%nsd, 1:valNNS), &
+ N(1:valNNS, 1:obj%nips))
END PROCEDURE elemsd_SetBarycentricCoord
!----------------------------------------------------------------------------
@@ -50,6 +58,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE stsd_SetBarycentricCoord
+! TODO: Improve this function by removing the temporary variable
+! It is better to store a temporary variable in obj itself
CALL SetBarycentricCoord(obj=obj, val=MATMUL(val, T), N=N)
END PROCEDURE stsd_SetBarycentricCoord
@@ -59,27 +69,43 @@
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 +114,24 @@
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%nsd, ips), &
+ invJacobian(1:obj%nsd, 1:obj%nsd))
+END DO
END PROCEDURE elemsd_SetdNdXt
!----------------------------------------------------------------------------
@@ -113,7 +139,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_SetJacobian
-obj%jacobian = MATMUL(val, dNdXi)
+INTEGER(I4B) :: valNNS, minNNS, ips
+
+valNNS = SIZE(val, 2)
+minNNS = MIN(valNNS, obj%nns)
+
+DO ips = 1, obj%nips
+ obj%jacobian(1:obj%nsd, 1:obj%xidim, ips) = MATMUL( &
+ val(1:obj%nsd, 1:minNNS), &
+ dNdXi(1:minNNS, 1:obj%xidim, ips))
+END DO
END PROCEDURE elemsd_SetJacobian
!----------------------------------------------------------------------------
@@ -121,7 +156,9 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE stsd_SetJacobian
-obj%jacobian = MATMUL(MATMUL(val, T), dNdXi)
+obj%jacobian(1:obj%nsd, 1:obj%xidim, 1:obj%nips) = &
+ MATMUL(MATMUL(val(1:obj%nsd, :, :), T), &
+ dNdXi(:, 1:obj%xidim, 1:obj%nips))
END PROCEDURE stsd_SetJacobian
!----------------------------------------------------------------------------
@@ -129,17 +166,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 +202,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,37 +244,26 @@
!----------------------------------------------------------------------------
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)
+call elemsd_Set1(obj=cellobj, val=cellval, N=cellN, dNdXi=celldNdXi)
-facetNptrs = GetConnectivity(facetobj%refelem)
-
-CALL SetJacobian(obj=facetobj, val=cellVal(:, facetNptrs), &
- & dNdXi=facetdNdXi)
+CALL SetJacobian(obj=facetobj, val=facetval, dNdXi=facetdNdXi)
CALL SetJs(obj=facetobj)
-CALL SetBarycentricCoord(obj=facetobj, val=cellval(:, facetNptrs), &
- & N=facetN)
-
+CALL SetBarycentricCoord(obj=facetobj, val=facetval, N=facetN)
CALL SetNormal(obj=facetobj)
! gradient depends upon all nodes of the element
! therefore the SIZE( dNdXt, 1 ) = NNS of cell
-
! CALL Reallocate( facetobj%dNdXt, SHAPE( cellobj%dNdXt) )
-facetobj%dNdXt = cellobj%dNdXt
+! facetobj%dNdXt(1:facetobj%nns, 1:facetobj%nsd, 1:facetobj%nips) = &
+! cellobj%dNdXt(1:cellobj%nns, 1:cellobj%nsd, 1:cellobj%nips)
! I am copying normal Js from facet to cell
! In this way, we can use cellobj to construct the element matrix
+cellobj%normal(1:cellobj%nsd, 1:cellobj%nips) = &
+ facetobj%normal(1:facetobj%nsd, 1:facetobj%nips)
-cellobj%normal = facetobj%normal
-cellobj%Js = facetobj%Js
-cellobj%Ws = facetobj%Ws
-
-IF (ALLOCATED(facetNptrs)) DEALLOCATE (facetNptrs)
+cellobj%Js(1:cellobj%nips) = facetobj%Js(1:facetobj%nips)
+cellobj%Ws(1:cellobj%nips) = facetobj%Ws(1:facetobj%nips)
END PROCEDURE elemsd_Set2
!----------------------------------------------------------------------------
@@ -226,25 +271,15 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE elemsd_Set3
-!
CALL Set( &
- & facetobj=masterFacetObj, &
- & cellobj=masterCellObj, &
- & cellVal=masterCellVal, &
- & cellN=masterCellN, &
- & celldNdXi=masterCelldNdXi, &
- & facetN=masterFacetN, &
- & facetdNdXi=masterFacetdNdXi)
-!
+ facetobj=masterFacetObj, cellobj=masterCellObj, cellVal=masterCellVal, &
+ cellN=masterCellN, celldNdXi=masterCelldNdXi, facetN=masterFacetN, &
+ facetdNdXi=masterFacetdNdXi, facetval=masterFacetVal)
+
CALL Set( &
- & facetobj=slaveFacetObj, &
- & cellobj=slaveCellObj, &
- & cellVal=slaveCellVal, &
- & cellN=slaveCellN, &
- & celldNdXi=slaveCelldNdXi, &
- & facetN=slaveFacetN, &
- & facetdNdXi=slaveFacetdNdXi)
-!
+ facetobj=slaveFacetObj, cellobj=slaveCellObj, cellVal=slaveCellVal, &
+ cellN=slaveCellN, celldNdXi=slaveCelldNdXi, facetN=slaveFacetN, &
+ facetdNdXi=slaveFacetdNdXi, facetVal=slaveFacetVal)
END PROCEDURE elemsd_Set3
!----------------------------------------------------------------------------
@@ -267,14 +302,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_StabilizationParamMethods@SUGN3.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90
index a9bda718e..251e2dc79 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUGN3.F90
@@ -35,7 +35,7 @@
& TypeFEVariableSpace)
END IF
!!
-CALL GetInterpolation(obj=obj, val=nu, interpol=nubar)
+CALL GetInterpolation(obj=obj, val=nu, ans=nubar)
!!
DO ii = 1, SIZE(h0)
h0(ii) = h0(ii)**2 / nubar(ii) / 4.0_DFP
@@ -66,7 +66,7 @@
& TypeFEVariableSpaceTime)
END IF
!!
-CALL GetInterpolation(obj=obj, val=nu, interpol=nubar)
+CALL GetInterpolation(obj=obj, val=nu, ans=nubar)
!!
DO ii = 1, SIZE(obj)
h0(:, ii) = h0(:, ii)**2 / nubar(:, ii) / 4.0_DFP
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90
index db36aea62..8e4751700 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@SUPG.F90
@@ -70,17 +70,18 @@ PURE SUBROUTINE elemsd_getSUPGParam_a(obj, tau, c, val, nu, k, &
!!
opt0 = INPUT(default=1_I4B, option=opt)
!!
- CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c)
+ CALL GetProjectionOfdNdXt(obj=obj, ans=p, c=c, crank=TypeFEVariableVector)
!!
CALL GetUnitNormal(obj=obj, val=val, r=r)
rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace)
- CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar)
+ CALL GetProjectionOfdNdXt(obj=obj, ans=q, c=rvar, &
+ crank=TypeFEVariableVector)
!!
- CALL GetInterpolation(obj=obj, val=nu, interpol=nubar)
+ CALL GetInterpolation(obj=obj, val=nu, ans=nubar)
!!
IF (PRESENT(k)) THEN
- CALL GetInterpolation(obj=obj, val=k, interpol=kbar)
- CALL GetInterpolation(obj=obj, val=phi, interpol=phibar)
+ CALL GetInterpolation(obj=obj, val=k, ans=kbar)
+ CALL GetInterpolation(obj=obj, val=phi, ans=phibar)
ELSE
ALLOCATE (kbar(SIZE(nubar)))
ALLOCATE (phibar(SIZE(nubar)))
@@ -129,7 +130,7 @@ END SUBROUTINE elemsd_getSUPGParam_a
!----------------------------------------------------------------------------
PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, &
- & phi, dt, opt)
+ phi, dt, opt)
CLASS(STElemshapeData_), INTENT(IN) :: obj
!! space-time element shape data
TYPE(FEVariable_), INTENT(INOUT) :: tau
@@ -174,7 +175,8 @@ PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, &
!!
opt0 = INPUT(option=opt, default=1_I4B)
!!
- CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=obj, ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
!! make cdNTdxt + dNTdt
!!
@@ -182,12 +184,13 @@ PURE SUBROUTINE elemsd_getSUPGParam_b(obj, tau, c, val, nu, k, &
!!
CALL GetUnitNormal(obj=obj, val=val, r=r)
rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace)
- CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar)
- CALL GetInterpolation(obj=obj, val=nu, interpol=nubar)
+ CALL GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, &
+ crank=TypeFEVariableVector)
+ CALL GetInterpolation(obj=obj, val=nu, ans=nubar)
!!
IF (PRESENT(k)) THEN
- CALL GetInterpolation(obj=obj, val=k, interpol=kbar)
- CALL GetInterpolation(obj=obj, val=phi, interpol=phibar)
+ CALL GetInterpolation(obj=obj, val=k, ans=kbar)
+ CALL GetInterpolation(obj=obj, val=phi, ans=phibar)
ELSE
ALLOCATE (kbar(SIZE(nubar)))
ALLOCATE (phibar(SIZE(nubar)))
@@ -350,11 +353,12 @@ PURE SUBROUTINE elemsd_getSUPGParam_c(obj, tau, c, val, nu, k, &
!!
opt0 = INPUT(default=1_I4B, option=opt)
!!
- CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=p, val=c)
+ CALL GetProjectionOfdNdXt(obj=obj, ans=p, c=c, crank=TypeFEVariableVector)
!!
CALL GetUnitNormal(obj=obj, val=val, r=r)
rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace)
- CALL GetProjectionOfdNdXt(obj=obj, cdNdXt=q, val=rvar)
+ CALL GetProjectionOfdNdXt(obj=obj, ans=q, c=rvar, &
+ crank=TypeFEVariableVector)
!!
IF (PRESENT(k)) THEN
kbar = k
@@ -399,7 +403,7 @@ END SUBROUTINE elemsd_getSUPGParam_c
!----------------------------------------------------------------------------
PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, &
- & phi, dt, opt)
+ phi, dt, opt)
CLASS(STElemshapeData_), INTENT(IN) :: obj
!! space-time element shape data
TYPE(FEVariable_), INTENT(INOUT) :: tau
@@ -440,7 +444,7 @@ PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, &
!!
opt0 = INPUT(default=1_I4B, option=opt)
!!
- CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=obj, ans=p, c=c, crank=TypeFEVariableVector)
!!
!! make cdNTdxt + dNTdt
!!
@@ -448,7 +452,8 @@ PURE SUBROUTINE elemsd_getSUPGParam_d(obj, tau, c, val, nu, k, &
!!
CALL GetUnitNormal(obj=obj, val=val, r=r)
rvar = QuadratureVariable(r, TypeFEVariableVector, TypeFEVariableSpace)
- CALL GetProjectionOfdNTdXt(obj=obj, cdNTdXt=q, val=rvar)
+ CALL GetProjectionOfdNTdXt(obj=obj, ans=q, c=rvar, &
+ crank=TypeFEVariableVector)
!!
IF (PRESENT(k)) THEN
kbar = k
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90
index 6d5a80042..296ab1a66 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_StabilizationParamMethods@Takizawa2018.F90
@@ -54,7 +54,7 @@
& TypeFEVariableSpace)
END IF
!
-CALL GetInterpolation(obj=obj, val=nu, interpol=nubar)
+CALL GetInterpolation(obj=obj, val=nu, ans=nubar)
CALL Reallocate(tau0, SIZE(h0))
!
DO ii = 1, SIZE(h0)
@@ -120,7 +120,7 @@
!
nips = SIZE(h0, 1)
!
-CALL GetInterpolation(obj=obj, val=nu, interpol=nubar)
+CALL GetInterpolation(obj=obj, val=nu, ans=nubar)
CALL Reallocate(tau0, nips, nipt)
!
DO ipt = 1, nipt
diff --git a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90
index 07a7d5fae..ab2ba6137 100644
--- a/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_UnitNormalMethods@Methods.F90
@@ -29,9 +29,9 @@
REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:)
INTEGER(I4B) :: ii
!! main
-CALL getInterpolation(obj=obj, Val=val, Interpol=p)
+CALL GetInterpolation(obj=obj, Val=val, ans=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)
@@ -62,11 +62,11 @@
INTEGER(I4B) :: i
!! main
!! interpolate the vector
-CALL getInterpolation(obj=obj, Interpol=p, Val=val)
+CALL getInterpolation(obj=obj, ans=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))
+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
-!! 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)
+ REAL(DFP), ALLOCATABLE :: dp(:, :), p(:), pnorm(:)
+ INTEGER(I4B) :: ii
+
+ CALL GetInterpolation(obj=obj, Val=val, ans=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, ans=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/ElemshapeData_VectorInterpolMethods@Methods.F90 b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90
new file mode 100644
index 000000000..daa1354f3
--- /dev/null
+++ b/src/submodules/ElemshapeData/src/ElemshapeData_VectorInterpolMethods@Methods.F90
@@ -0,0 +1,361 @@
+! 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_VectorInterpolMethods) Methods
+USE ReallocateUtility, ONLY: Reallocate
+USE FEVariable_Method, ONLY: FEVariableSize => Size
+
+USE BaseType, ONLY: TypeFEVariableOpt, TypeFEVariableVector, &
+ TypeFEVariableConstant, TypeFEVariableSpace, &
+ TypeFEVariableSpaceTime
+
+USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_
+
+IMPLICIT NONE
+
+CONTAINS
+
+!---------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation1
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+INTEGER(I4B) :: nrow, ncol
+
+nrow = SIZE(val, 1)
+ncol = obj%nips
+CALL Reallocate(ans, nrow, ncol)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_1
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_1a
+INTEGER(I4B) :: valNNS, minNNS
+nrow = SIZE(val, 1)
+ncol = obj%nips
+
+valNNS = SIZE(val, 2)
+minNNS = MIN(valNNS, obj%nns)
+
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ scale * MATMUL(val(1:nrow, 1:minNNS), &
+ obj%N(1:minNNS, 1:ncol))
+END PROCEDURE GetInterpolation_1a
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation2
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+INTEGER(I4B) :: nrow, ncol
+
+nrow = SIZE(val, 1)
+ncol = obj%nips
+CALL Reallocate(ans, nrow, ncol)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_2
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_2a
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+INTEGER(I4B) :: minNNT, valNNT, aa
+REAL(DFP) :: myscale
+
+nrow = SIZE(val, 1)
+ncol = obj%nips
+
+valNNT = SIZE(val, 3)
+minNNT = MIN(valNNT, obj%nnt)
+
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+DO aa = 1, minNNT
+ myscale = obj%T(aa) * scale
+ CALL GetInterpolation_(obj=obj, ans=ans, val=val(:, :, aa), nrow=nrow, &
+ ncol=ncol, scale=myscale, addContribution=yes)
+END DO
+END PROCEDURE GetInterpolation_2a
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation3
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = SIZE(val, 1)
+dim2 = obj(1)%nips
+dim3 = SIZE(obj)
+
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_3
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_3a
+INTEGER(I4B) :: ipt
+
+dim3 = SIZE(obj)
+
+DO ipt = 1, dim3
+ CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, ipt), &
+ val=val, nrow=dim1, ncol=dim2, scale=scale, &
+ addContribution=addContribution)
+END DO
+END PROCEDURE GetInterpolation_3a
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation4
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+INTEGER(I4B) :: nrow, ncol
+
+nrow = FEVariableSize(val, 1)
+ncol = obj%nips
+
+CALL Reallocate(ans, nrow, ncol)
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation4
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, nrow=nrow, ncol=ncol, &
+ scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_4
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4a
+INTEGER(I4B) :: timeIndx0
+timeIndx0 = 1_I4B
+IF (PRESENT(timeIndx)) timeIndx0 = timeIndx
+
+SELECT CASE (val%vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableConstant, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeFEVariableOpt%space)
+
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpace, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeFEVariableOpt%spacetime)
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=obj%N, nns=obj%nns, nips=obj%nips, &
+ T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, nrow=nrow, ncol=ncol, &
+ timeIndx=timeIndx0)
+
+ END SELECT
+
+END SELECT
+END PROCEDURE GetInterpolation_4a
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_4b
+SELECT CASE (val%vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableConstant, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, tsize=tsize)
+
+CASE (TypeFEVariableOpt%space)
+
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpace, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, tsize=tsize)
+
+CASE (TypeFEVariableOpt%spacetime)
+
+ SELECT TYPE (obj); TYPE IS (STElemShapeData_)
+ CALL FEVariableGetInterpolation_(obj=val, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=obj%N, nns=obj%nns, &
+ spaceIndx=spaceIndx, &
+ timeIndx=timeIndx, &
+ T=obj%T, nnt=obj%nnt, &
+ scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, tsize=tsize)
+
+ END SELECT
+
+END SELECT
+END PROCEDURE GetInterpolation_4b
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation5
+INTEGER(I4B) :: dim1, dim2, dim3
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+dim1 = FEVariableSIZE(val, 1)
+dim2 = obj(1)%nips
+dim3 = SIZE(obj)
+
+CALL Reallocate(ans, dim1, dim2, dim3)
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation5
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_5
+REAL(DFP), PARAMETER :: one = 1.0_DFP
+LOGICAL(LGT), PARAMETER :: no = .FALSE.
+
+dim1 = FEVariableSIZE(val, 1)
+dim2 = obj(1)%nips
+dim3 = SIZE(obj)
+
+CALL GetInterpolation_(obj=obj, ans=ans, val=val, dim1=dim1, dim2=dim2, &
+ dim3=dim3, scale=one, addContribution=no)
+END PROCEDURE GetInterpolation_5
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetInterpolation_5a
+INTEGER(I4B) :: ipt
+
+dim1 = 0
+dim2 = 0
+dim3 = SIZE(obj)
+DO ipt = 1, dim3
+ CALL GetInterpolation_(obj=obj(ipt), ans=ans(:, :, ipt), &
+ val=val, nrow=dim1, ncol=dim2, &
+ scale=scale, addContribution=addContribution, &
+ timeIndx=ipt)
+END DO
+END PROCEDURE GetInterpolation_5a
+
+!----------------------------------------------------------------------------
+! Interpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Interpolation1
+CALL GetInterpolation(obj=obj, ans=ans, val=val)
+END PROCEDURE Interpolation1
+
+!----------------------------------------------------------------------------
+! STInterpolation
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE STInterpolation1
+CALL GetInterpolation(obj=obj, ans=ans, val=val)
+END PROCEDURE STInterpolation1
+
+END SUBMODULE Methods
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/CMakeLists.txt b/src/submodules/FEVariable/CMakeLists.txt
index ebcb11b22..46461d104 100644
--- a/src/submodules/FEVariable/CMakeLists.txt
+++ b/src/submodules/FEVariable/CMakeLists.txt
@@ -1,35 +1,39 @@
-# 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}/FEVariable_Method@ConstructorMethods.F90
- ${src_path}/FEVariable_Method@IOMethods.F90
- ${src_path}/FEVariable_Method@GetMethods.F90
- ${src_path}/FEVariable_Method@AdditionMethods.F90
- ${src_path}/FEVariable_Method@SubtractionMethods.F90
- ${src_path}/FEVariable_Method@MultiplicationMethods.F90
- ${src_path}/FEVariable_Method@DivisionMethods.F90
- ${src_path}/FEVariable_Method@PowerMethods.F90
- ${src_path}/FEVariable_Method@SqrtMethods.F90
- ${src_path}/FEVariable_Method@AbsMethods.F90
- ${src_path}/FEVariable_Method@DotProductMethods.F90
- ${src_path}/FEVariable_Method@Norm2Methods.F90
- ${src_path}/FEVariable_Method@EqualMethods.F90
- ${src_path}/FEVariable_Method@MeanMethods.F90
-)
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/FEVariable_AdditionMethod@Methods.F90
+ ${src_path}/FEVariable_ConstructorMethod@Methods.F90
+ ${src_path}/FEVariable_NodalVariableMethod@Methods.F90
+ ${src_path}/FEVariable_QuadratureVariableMethod@Methods.F90
+ ${src_path}/FEVariable_DivisionMethod@Methods.F90
+ ${src_path}/FEVariable_MultiplicationMethod@Methods.F90
+ ${src_path}/FEVariable_DotProductMethod@Methods.F90
+ ${src_path}/FEVariable_SubtractionMethod@Methods.F90
+ ${src_path}/FEVariable_MeanMethod@Methods.F90
+ ${src_path}/FEVariable_UnaryMethod@Methods.F90
+ ${src_path}/FEVariable_GetMethod@Methods.F90
+ ${src_path}/FEVariable_IOMethod@Methods.F90
+ ${src_path}/FEVariable_ScalarInterpolationMethod@Methods.F90
+ ${src_path}/FEVariable_VectorInterpolationMethod@Methods.F90
+ ${src_path}/FEVariable_MatrixInterpolationMethod@Methods.F90
+ ${src_path}/FEVariable_InterpolationMethod@Methods.F90
+ ${src_path}/FEVariable_SetMethod@ScalarMethods.F90
+ ${src_path}/FEVariable_SetMethod@VectorMethods.F90
+ ${src_path}/FEVariable_SetMethod@MatrixMethods.F90)
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90
similarity index 54%
rename from src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90
rename to src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90
index 7efae1312..2fc8a85ae 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@AdditionMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_AdditionMethod@Methods.F90
@@ -14,10 +14,26 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
+
+SUBMODULE(FEVariable_AdditionMethod) Methods
+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
+
+USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+
#define _OP_ +
-SUBMODULE(FEVariable_Method) AdditionMethods
-USE BaseMethod
IMPLICIT NONE
CONTAINS
@@ -26,62 +42,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 +77,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,35 +92,18 @@
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
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-END SUBMODULE AdditionMethods
+END SUBMODULE Methods
#undef _OP_
diff --git a/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90
new file mode 100644
index 000000000..f4c60f83e
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_ConstructorMethod@Methods.F90
@@ -0,0 +1,114 @@
+! 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(FEVariable_ConstructorMethod) Methods
+USE ReallocateUtility, ONLY: Reallocate
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Initiate1
+CALL Initiate(obj=obj, s=s, defineon=defineon, vartype=vartype, rank=rank, &
+ len=len)
+obj%val(1:obj%len) = val(1:obj%len)
+END PROCEDURE obj_Initiate1
+
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Initiate2
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tsize
+
+obj%tshape = SIZE(s)
+obj%isInit = .TRUE.
+obj%s(1:obj%tshape) = s(1:obj%tshape)
+obj%defineon = defineon
+obj%vartype = vartype
+obj%rank = rank
+obj%len = len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len
+
+isok = ALLOCATED(obj%val)
+IF (.NOT. isok) THEN
+ CALL Reallocate(obj%val, obj%capacity)
+ RETURN
+END IF
+
+tsize = SIZE(obj%val)
+IF (tsize .GE. obj%len) THEN
+ obj%capacity = tsize
+ obj%val(1:obj%capacity) = 0.0_DFP
+ELSE
+ CALL Reallocate(obj%val, obj%capacity)
+END IF
+
+END PROCEDURE obj_Initiate2
+
+!----------------------------------------------------------------------------
+! Deallocate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Deallocate
+obj%isInit = .FALSE.
+obj%s = 0
+obj%tshape = 0
+obj%defineOn = 0
+obj%vartype = 0
+obj%rank = 0
+obj%len = 0
+obj%capacity = 0
+IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val)
+END PROCEDURE obj_Deallocate
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy
+LOGICAL(LGT) :: isok
+
+obj1%s = obj2%s
+obj1%tshape = obj2%tshape
+obj1%defineOn = obj2%defineOn
+obj1%rank = obj2%rank
+obj1%vartype = obj2%vartype
+obj1%len = obj2%len
+obj1%isInit = obj2%isInit
+
+IF (obj1%capacity .GE. obj1%len) THEN
+ obj1%val(1:obj1%len) = obj2%val(1:obj1%len)
+ RETURN
+END IF
+
+obj1%capacity = TypeFEVariableOpt%capacityExpandFactor * obj1%len
+CALL Reallocate(obj1%val, obj1%capacity)
+
+isok = ALLOCATED(obj2%val)
+IF (isok) obj1%val(1:obj1%len) = obj2%val(1:obj1%len)
+END PROCEDURE obj_Copy
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90
similarity index 53%
rename from src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90
rename to src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90
index 2bf089160..287a9b1ca 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@DivisionMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_DivisionMethod@Methods.F90
@@ -14,11 +14,28 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
+
+SUBMODULE(FEVariable_DivisionMethod) Methods
+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
+
+USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+
#define _OP_ /
-SUBMODULE(FEVariable_Method) DivisionMethods
-USE BaseMethod
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -26,62 +43,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 +92,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 +111,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 Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90
new file mode 100644
index 000000000..11f39e0ca
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_DotProductMethod@Methods.F90
@@ -0,0 +1,287 @@
+! 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(FEVariable_DotProductMethod) Methods
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! DOT_PRODUCT
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_dot_product
+! !! Internal variable
+! REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:, :), r3(:, :, :), m3(:, :, :)
+! INTEGER(I4B) :: jj, kk
+!
+! ! main
+! SELECT CASE (obj1%vartype)
+!
+! CASE (constant)
+!
+! SELECT CASE (obj2%vartype)
+!
+! ! constant = constant DOT_PRODUCT constant
+! CASE (constant)
+!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable( &
+! & DOT_PRODUCT(obj1%val(:), obj2%val(:)), &
+! & typeFEVariableScalar, &
+! & typeFEVariableConstant)
+! ELSE
+! ans = QuadratureVariable( &
+! & DOT_PRODUCT(obj1%val(:), obj2%val(:)), &
+! & typeFEVariableScalar, &
+! & typeFEVariableConstant)
+! END IF
+!
+! ! space= constant DOT_PRODUCT space
+! CASE (space)
+!
+! r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
+!
+! IF (obj2%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & MATMUL(obj1%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpace)
+! ELSE
+! ans = QuadratureVariable(&
+! & MATMUL(obj1%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpace)
+! END IF
+!
+! ! time=constant DOT_PRODUCT time
+! CASE (time)
+!
+! r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
+!
+! IF (obj2%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & MATMUL(obj1%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableTime)
+! ELSE
+! ans = QuadratureVariable(&
+! & MATMUL(obj1%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableTime)
+! END IF
+! !!
+! !! spacetime=constant DOT_PRODUCT spacetime
+! !!
+! CASE (spacetime)
+! !!
+! r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime)
+! !!
+! IF (obj2%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & MATMUL(obj1%val, r3), &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpaceTime)
+! ELSE
+! ans = QuadratureVariable(&
+! & MATMUL(obj1%val, r3), &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpaceTime)
+! END IF
+! !!
+! END SELECT
+! !!
+! !!
+! !!
+! !!
+! CASE (space)
+! !!
+! SELECT CASE (obj2%vartype)
+! !!
+! !! space=space DOT_PRODUCT constant
+! !!
+! CASE (constant)
+! !!
+! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
+! !!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & MATMUL(obj2%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpace)
+! ELSE
+! ans = QuadratureVariable(&
+! & MATMUL(obj2%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpace)
+! END IF
+! !!
+! !! space=space DOT_PRODUCT space
+! !!
+! CASE (space)
+! !!
+! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
+! m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
+! CALL Reallocate(r1, SIZE(r2, 2))
+! !!
+! DO jj = 1, SIZE(r1)
+! r1(jj) = DOT_PRODUCT(r2(:, jj), m2(:, jj))
+! END DO
+! !!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable( &
+! & r1, &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpace)
+! ELSE
+! ans = QuadratureVariable( &
+! & r1, &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpace)
+! END IF
+! !!
+! END SELECT
+! !!
+! !!
+! !!
+! !!
+! CASE (time)
+! !!
+! SELECT CASE (obj2%vartype)
+! !!
+! !! time=time DOT_PRODUCT constant
+! !!
+! CASE (constant)
+! !!
+! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
+! !!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & MATMUL(obj2%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableTime)
+! ELSE
+! ans = QuadratureVariable(&
+! & MATMUL(obj2%val, r2), &
+! & typeFEVariableScalar, &
+! & typeFEVariableTime)
+! END IF
+! !!
+! !! time=time DOT_PRODUCT time
+! !!
+! CASE (time)
+! !!
+! r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
+! m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
+! CALL Reallocate(r1, SIZE(r2, 2))
+! !!
+! DO jj = 1, SIZE(r1)
+! r1(jj) = DOT_PRODUCT(r2(:, jj), m2(:, jj))
+! END DO
+! !!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable( &
+! & r1, &
+! & typeFEVariableScalar, &
+! & typeFEVariableTime)
+! ELSE
+! ans = QuadratureVariable( &
+! & r1, &
+! & typeFEVariableScalar, &
+! & typeFEVariableTime)
+! END IF
+! !!
+! END SELECT
+! !!
+! CASE (spacetime)
+! !!
+! SELECT CASE (obj2%vartype)
+! !!
+! !! spacetime= spacetime DOT_PRODUCT constant
+! !!
+! CASE (constant)
+! !!
+! r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime)
+! CALL Reallocate(r2, SIZE(r3, 2), SIZE(r3, 3))
+! !!
+! DO kk = 1, SIZE(r3, 3)
+! DO jj = 1, SIZE(r3, 2)
+! r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), obj2%val(:))
+! END DO
+! END DO
+! !!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & r2, &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpaceTime)
+! ELSE
+! ans = QuadratureVariable(&
+! & r2, &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpaceTime)
+! END IF
+! !!
+! !! spacetime=spacetime DOT_PRODUCT spacetime
+! !!
+! CASE (spacetime)
+! !!
+! r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime)
+! m3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime)
+! !!
+! CALL Reallocate(r2, SIZE(r3, 2), SIZE(r3, 3))
+! !!
+! DO kk = 1, SIZE(r3, 3)
+! DO jj = 1, SIZE(r3, 2)
+! r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), m3(:, jj, kk))
+! END DO
+! END DO
+! !!
+! IF (obj1%defineon .EQ. nodal) THEN
+! ans = NodalVariable(&
+! & r2, &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpaceTime)
+! ELSE
+! ans = QuadratureVariable(&
+! & r2, &
+! & typeFEVariableScalar, &
+! & typeFEVariableSpaceTime)
+! END IF
+! !!
+! END SELECT
+! !!
+! END SELECT
+END PROCEDURE fevar_dot_product
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90
new file mode 100644
index 000000000..82e53bc5c
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_GetMethod@Methods.F90
@@ -0,0 +1,524 @@
+! 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(FEVariable_GetMethod) Methods
+USE ReallocateUtility, ONLY: Reallocate
+USE StringUtility, ONLY: UpperCase
+USE BaseType, ONLY: feopt => TypeFEVariableOpt
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Len
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_len
+ans = obj%len
+END PROCEDURE fevar_len
+
+!----------------------------------------------------------------------------
+! FEVariable_ToString
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FEVariable_ToChar
+
+SELECT CASE (name)
+CASE (feopt%scalar)
+ ans = "Scalar"
+
+CASE (feopt%vector)
+ ans = "Vector"
+
+CASE (feopt%matrix)
+ ans = "Matrix"
+
+CASE DEFAULT
+ ans = "Scalar"
+
+END SELECT
+
+IF (PRESENT(isUpper)) THEN
+ IF (isUpper) THEN
+ ans = UpperCase(ans)
+ END IF
+END IF
+
+END PROCEDURE FEVariable_ToChar
+
+!----------------------------------------------------------------------------
+! FEVariable_ToInteger
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FEVariable_ToInteger
+CHARACTER(1) :: name0
+
+name0 = name(1:1)
+
+SELECT CASE (name0)
+CASE ("S", "s")
+ ans = feopt%scalar
+
+CASE ("V", "v")
+ ans = feopt%vector
+
+CASE ("M", "m")
+ ans = feopt%matrix
+
+CASE DEFAULT
+ ans = feopt%scalar
+
+END SELECT
+
+END PROCEDURE FEVariable_ToInteger
+
+!----------------------------------------------------------------------------
+! GetLambdaFromYoungsModulus
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_GetLambdaFromYoungsModulus
+INTEGER(I4B) :: ii
+
+lambda = youngsModulus
+
+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
+
+END PROCEDURE fevar_GetLambdaFromYoungsModulus
+
+!----------------------------------------------------------------------------
+! Size
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Size
+LOGICAL(LGT) :: isok
+
+isok = PRESENT(dim)
+IF (isok) THEN
+ ans = obj%s(dim)
+ELSE
+ ans = obj%len
+END IF
+END PROCEDURE fevar_Size
+
+!----------------------------------------------------------------------------
+! GetTotalShape
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_GetTotalShape
+ans = obj%tshape
+! SELECT CASE (obj%rank)
+! CASE (feopt%scalar)
+! SELECT CASE (obj%vartype)
+! CASE (feopt%constant, feopt%space, feopt%time)
+! ans = 1
+! CASE (feopt%spaceTime)
+! ans = 2
+! END SELECT
+!
+! CASE (feopt%vector)
+! SELECT CASE (obj%vartype)
+! CASE (feopt%constant)
+! ans = 1
+! CASE (feopt%space, feopt%time)
+! ans = 2
+! CASE (feopt%spaceTime)
+! ans = 3
+! END SELECT
+!
+! CASE (feopt%matrix)
+! SELECT CASE (obj%vartype)
+! CASE (feopt%constant)
+! ans = 2
+! CASE (feopt%space, feopt%time)
+! ans = 3
+! CASE (feopt%spaceTime)
+! ans = 4
+! END SELECT
+!
+! END SELECT
+END PROCEDURE fevar_GetTotalShape
+
+!----------------------------------------------------------------------------
+! Shape
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Shape
+! INTEGER(I4B) :: tsize
+! tsize = GetTotalShape(obj=obj)
+CALL Reallocate(ans, obj%tshape)
+ans(1:obj%tshape) = obj%s(1:obj%tshape)
+END PROCEDURE fevar_Shape
+
+!----------------------------------------------------------------------------
+! Shape
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_GetShape
+! tsize = GetTotalShape(obj=obj)
+tsize = obj%tshape
+ans(1:tsize) = obj%s(1:tsize)
+END PROCEDURE fevar_GetShape
+
+!----------------------------------------------------------------------------
+! rank
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_rank
+ans = obj%rank
+END PROCEDURE fevar_rank
+
+!----------------------------------------------------------------------------
+! vartype
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_vartype
+ans = obj%vartype
+END PROCEDURE fevar_vartype
+
+!----------------------------------------------------------------------------
+! defineon
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_defineon
+ans = obj%defineon
+END PROCEDURE fevar_defineon
+
+!----------------------------------------------------------------------------
+! isNodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_isNodalVariable
+ans = obj%defineon .EQ. feopt%nodal
+END PROCEDURE fevar_isNodalVariable
+
+!----------------------------------------------------------------------------
+! isNodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_isQuadratureVariable
+ans = obj%defineon .NE. feopt%nodal
+END PROCEDURE fevar_isQuadratureVariable
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Constant
+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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE Master_get_mat4_(obj, val, dim1, dim2, dim3, dim4)
+ CLASS(FEVariable_), INTENT(IN) :: obj
+ REAL(DFP), INTENT(INOUT) :: val(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ ! Internal variables
+ 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 SUBROUTINE Master_get_mat4_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Space
+INTEGER(I4B) :: tsize
+ALLOCATE (val(obj%len))
+CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize)
+END PROCEDURE Scalar_Space
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Space_
+CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize)
+END PROCEDURE Scalar_Space_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Time
+INTEGER(I4B) :: tsize
+ALLOCATE (val(obj%len))
+CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize)
+END PROCEDURE Scalar_Time
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_Time_
+CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize)
+END PROCEDURE Scalar_Time_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_SpaceTime
+INTEGER(I4B) :: nrow, ncol
+ALLOCATE (val(obj%s(1), obj%s(2)))
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Scalar_SpaceTime
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Scalar_SpaceTime_
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Scalar_SpaceTime_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Constant
+INTEGER(I4B) :: tsize
+ALLOCATE (val(obj%len))
+CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize)
+END PROCEDURE Vector_Constant
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Constant_
+CALL Master_Get_vec_(obj=obj, val=val, tsize=tsize)
+END PROCEDURE Vector_Constant_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Space
+INTEGER(I4B) :: nrow, ncol
+ALLOCATE (val(obj%s(1), obj%s(2)))
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Vector_Space
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Space_
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Vector_Space_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Time
+INTEGER(I4B) :: nrow, ncol
+ALLOCATE (val(obj%s(1), obj%s(2)))
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Vector_Time
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_Time_
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Vector_Time_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_SpaceTime
+INTEGER(I4B) :: dim1, dim2, dim3
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3)))
+CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE Vector_SpaceTime
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Vector_SpaceTime_
+CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE Vector_SpaceTime_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Constant
+INTEGER(I4B) :: nrow, ncol
+ALLOCATE (val(obj%s(1), obj%s(2)))
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Matrix_Constant
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Constant_
+CALL Master_Get_mat_(obj=obj, val=val, nrow=nrow, ncol=ncol)
+END PROCEDURE Matrix_Constant_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Space
+INTEGER(I4B) :: dim1, dim2, dim3
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3)))
+CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE Matrix_Space
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Space_
+CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE Matrix_Space_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Time
+INTEGER(I4B) :: dim1, dim2, dim3
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3)))
+CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE Matrix_Time
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_Time_
+CALL Master_Get_mat3_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE Matrix_Time_
+
+!----------------------------------------------------------------------------
+! getNodalvalues
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_SpaceTime
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+ALLOCATE (val(obj%s(1), obj%s(2), obj%s(3), obj%s(4)))
+CALL Master_get_mat4_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4)
+END PROCEDURE Matrix_SpaceTime
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Matrix_SpaceTime_
+CALL Master_get_mat4_(obj=obj, val=val, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4)
+END PROCEDURE Matrix_SpaceTime_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.F90
new file mode 100644
index 000000000..25d53c643
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_IOMethod@Methods.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
+!
+
+SUBMODULE(FEVariable_IOMethod) Methods
+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
+
+USE FEVariable_Method, ONLY: GET, NodalVariable, QuadratureVariable
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Display
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Display
+CALL Util_Display(msg, unitno=unitno)
+
+SELECT CASE (obj%rank)
+
+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
+
+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
+
+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%tshape, "tshape: ", 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(obj%isInit, "isInit: ", unitno=unitno)
+CALL Util_Display(SafeSize(obj%val), "Size of obj%val: ", unitno=unitno)
+
+END PROCEDURE fevar_Display
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90
new file mode 100644
index 000000000..65e187578
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_InterpolationMethod@Methods.F90
@@ -0,0 +1,201 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_InterpolationMethod) Methods
+USE FEVariable_Method, ONLY: FEVariableCopy => Copy, &
+ FEVariableGetInterpolation_ => GetInterpolation_
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FEVariableGetInterpolation_1
+INTEGER(I4B) :: timeIndx
+
+timeIndx = 1
+
+! if val is a nodal variable then interpolate
+SELECT CASE (obj%rank)
+
+CASE (TypeFEVariableOpt%scalar)
+
+ SELECT CASE (obj%vartype)
+ CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableConstant, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+
+ CASE (TypeFEVariableOpt%space, TypeFEVariableOpt%spacetime)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpace, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ ! CASE (TypeFEVariableOpt%time)
+
+ END SELECT
+
+CASE (TypeFEVariableOpt%vector)
+
+ SELECT CASE (obj%vartype)
+ CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableConstant, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+
+ CASE (TypeFEVariableOpt%space, TypeFEVariableOpt%spacetime)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpace, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ ! CASE (TypeFEVariableOpt%time)
+
+ END SELECT
+
+CASE (TypeFEVariableOpt%matrix)
+
+ SELECT CASE (obj%vartype)
+ CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableConstant, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+
+ CASE (TypeFEVariableOpt%space, TypeFEVariableOpt%spacetime)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpace, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ ! CASE (TypeFEVariableOpt%time)
+
+ END SELECT
+
+END SELECT
+
+END PROCEDURE FEVariableGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FEVariableGetInterpolation_2
+! if val is a nodal variable then interpolate
+SELECT CASE (obj%rank)
+
+CASE (TypeFEVariableOpt%scalar)
+
+ SELECT CASE (obj%vartype)
+ CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableConstant, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpace, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ ! CASE (TypeFEVariableOpt%time)
+
+ CASE (TypeFEVariableOpt%spacetime)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableScalar, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=N, nns=nns, nips=nips, &
+ T=T, nnt=nnt, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+
+ END SELECT
+
+CASE (TypeFEVariableOpt%vector)
+
+ SELECT CASE (obj%vartype)
+ CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableConstant, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpace, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ ! CASE (TypeFEVariableOpt%time)
+
+ CASE (TypeFEVariableOpt%spacetime)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableVector, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=N, nns=nns, nips=nips, &
+ T=T, nnt=nnt, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+
+ END SELECT
+
+CASE (TypeFEVariableOpt%matrix)
+
+ SELECT CASE (obj%vartype)
+ CASE (TypeFEVariableOpt%constant)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableConstant, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ CASE (TypeFEVariableOpt%space)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpace, &
+ N=N, nns=nns, nips=nips, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+ ! CASE (TypeFEVariableOpt%time)
+
+ CASE (TypeFEVariableOpt%spacetime)
+ CALL FEVariableGetInterpolation_(obj=obj, rank=TypeFEVariableMatrix, &
+ vartype=TypeFEVariableSpaceTime, &
+ N=N, nns=nns, nips=nips, &
+ T=T, nnt=nnt, scale=scale, &
+ addContribution=addContribution, &
+ ans=ans, timeIndx=timeIndx)
+
+ END SELECT
+
+END SELECT
+
+END PROCEDURE FEVariableGetInterpolation_2
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90
new file mode 100644
index 000000000..c00dba2ee
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_MatrixInterpolationMethod@Methods.F90
@@ -0,0 +1,571 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_MatrixInterpolationMethod) Methods
+USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, &
+ TypeFEVariableTime, TypeFEVariableSpaceTime
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixConstantGetInterpolation_1
+INTEGER(I4B) :: ips, ii, jj, indx
+
+dim1 = obj%s(1)
+dim2 = obj%s(2)
+dim3 = nips
+
+IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+DO ips = 1, dim3
+ DO jj = 1, dim2
+ DO ii = 1, dim1
+ indx = (jj - 1) * dim1 + ii
+ ans(ii, jj, ips) = ans(ii, jj, ips) + scale * obj%val(indx)
+ END DO
+ END DO
+END DO
+END PROCEDURE MatrixConstantGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixConstantGetInterpolation_2
+INTEGER(I4B) :: tsize, ansStart, valStart, ii
+
+tsize = ans%s(1) * ans%s(2) * nips
+ansStart = (timeIndx - 1) * tsize
+IF (.NOT. addContribution) ans%val(ansStart + 1:ansStart + tsize) = 0.0_DFP
+
+valStart = 0
+DO ii = 1, tsize
+ ans%val(ansStart + ii) = ans%val(ansStart + ii) &
+ + scale * obj%val(valStart + ii)
+END DO
+END PROCEDURE MatrixConstantGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixConstantGetInterpolation_3
+INTEGER(I4B) :: ii, jj, indx
+
+nrow = obj%s(1)
+ncol = obj%s(2)
+
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ indx = (jj - 1) * nrow + ii
+ ans(ii, jj) = ans(ii, jj) + scale * obj%val(indx)
+ END DO
+END DO
+END PROCEDURE MatrixConstantGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromNodal1_(ans, scale, N, nns, dim1, &
+ dim2, nips, val, valStart, &
+ valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, nips, dim1, dim2
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: ips, ii, jj, inode, tsize, indx, a, b
+
+ tsize = dim1 * dim2
+
+ DO ips = 1, nips
+ DO inode = 1, nns
+ a = (inode - 1) * tsize
+
+ DO jj = 1, dim2
+ b = (jj - 1) * dim1
+
+ DO ii = 1, dim1
+ indx = a + b + ii + valStart
+ ans(ii, jj, ips) = ans(ii, jj, ips) &
+ + scale * N(inode, ips) * val(indx)
+
+ END DO
+ END DO
+ END DO
+ END DO
+
+ valEnd = valStart + nns * tsize
+END SUBROUTINE MasterGetInterpolationFromNodal1_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromNodal2_(ans, scale, N, nns, dim1, &
+ dim2, nips, val, valStart, &
+ valEnd, ansStart, ansEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, nips, dim1, dim2
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+ INTEGER(I4B), INTENT(IN) :: ansStart
+ INTEGER(I4B), INTENT(OUT) :: ansEnd
+
+ INTEGER(I4B) :: ips, jj, ival, jval, ians, jans, tsize
+
+ tsize = dim1 * dim2
+
+ DO ips = 1, nips
+ ians = (ips - 1) * tsize + 1 + ansStart
+ jans = ips * tsize + ansStart
+
+ DO jj = 1, nns
+ ival = (jj - 1) * tsize + 1 + valStart
+ jval = jj * tsize + valStart
+
+ ans(ians:jans) = ans(ians:jans) &
+ + scale * N(jj, ips) * val(ival:jval)
+ END DO
+ END DO
+
+ valEnd = valStart + nns * tsize
+ ansEnd = ansStart + nips * tsize
+END SUBROUTINE MasterGetInterpolationFromNodal2_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromNodal3_(ans, scale, N, nns, dim1, &
+ dim2, spaceIndx, &
+ val, valStart, valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, dim1, dim2, spaceIndx
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: ii, jj, inode, tsize, indx, a, b
+
+ tsize = dim1 * dim2
+
+ DO inode = 1, nns
+ a = (inode - 1) * tsize
+
+ DO jj = 1, dim2
+ b = (jj - 1) * dim1
+
+ DO ii = 1, dim1
+ indx = a + b + ii + valStart
+ ans(ii, jj) = ans(ii, jj) &
+ + scale * N(inode, spaceIndx) * val(indx)
+
+ END DO
+ END DO
+ END DO
+
+ valEnd = valStart + nns * tsize
+END SUBROUTINE MasterGetInterpolationFromNodal3_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromQuadrature1_(ans, scale, dim1, &
+ dim2, nips, val, &
+ valStart, valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: ips, ii, jj, tsize, indx, a, b
+
+ tsize = dim1 * dim2
+
+ DO ips = 1, nips
+ a = (ips - 1) * tsize
+
+ DO jj = 1, dim2
+ b = (jj - 1) * dim1
+
+ DO ii = 1, dim1
+ indx = a + b + ii + valStart
+ ans(ii, jj, ips) = ans(ii, jj, ips) + scale * val(indx)
+
+ END DO
+ END DO
+ END DO
+
+ valEnd = valStart + nips * tsize
+END SUBROUTINE MasterGetInterpolationFromQuadrature1_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolationFromQuadrature_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromQuadrature2_(ans, scale, dim1, &
+ dim2, nips, val, &
+ valStart, valEnd, &
+ ansStart, ansEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+ INTEGER(I4B), INTENT(IN) :: ansStart
+ INTEGER(I4B), INTENT(OUT) :: ansEnd
+
+ INTEGER(I4B) :: ii, tsize
+
+ tsize = nips * dim1 * dim2
+ valEnd = valStart + tsize
+ ansEnd = ansStart + tsize
+
+ DO ii = 1, tsize
+ ans(ansStart + ii) = ans(ansStart + ii) + scale * val(valStart + ii)
+ END DO
+END SUBROUTINE MasterGetInterpolationFromQuadrature2_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromQuadrature3_(ans, scale, dim1, &
+ dim2, spaceIndx, val, &
+ valStart, valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(IN) :: dim1, dim2, spaceIndx
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: ii, jj, tsize, indx, a, b
+
+ tsize = dim1 * dim2
+
+ a = (spaceIndx - 1) * tsize
+ DO jj = 1, dim2
+ b = (jj - 1) * dim1
+
+ DO ii = 1, dim1
+ indx = a + b + ii + valStart
+ ans(ii, jj) = ans(ii, jj) + scale * val(indx)
+ END DO
+ END DO
+
+ valEnd = valStart + tsize
+END SUBROUTINE MasterGetInterpolationFromQuadrature3_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! obj%defineon is nodal
+! Nodal Matrix Space
+! Convert nodal values to quadrature values by using N(:,:)
+! make sure nns .LE. obj%len
+!
+! obj%defineon is quadrature
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+MODULE PROCEDURE MatrixSpaceGetInterpolation_1
+INTEGER(I4B) :: valEnd
+
+dim1 = obj%s(1)
+dim2 = obj%s(2)
+dim3 = nips
+
+IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=scale, N=N, &
+ nns=nns, nips=nips, val=obj%val, &
+ dim1=dim1, dim2=dim2, &
+ valStart=0, valEnd=valEnd)
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, &
+ nips=nips, dim1=dim1, &
+ dim2=dim2, val=obj%val, &
+ valStart=0, valEnd=valEnd)
+
+END SELECT
+END PROCEDURE MatrixSpaceGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixSpaceGetInterpolation_2
+INTEGER(I4B) :: valStart, valEnd, ansStart, ansEnd, dim1, dim2, dim3, tsize
+
+dim1 = ans%s(1)
+dim2 = ans%s(2)
+dim3 = nips
+
+tsize = dim1 * dim2 * dim3
+ansStart = (timeIndx - 1) * tsize
+ansEnd = ansStart + tsize
+valStart = 0
+
+IF (.NOT. addContribution) ans%val(ansStart + 1:ansEnd) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=scale, N=N, &
+ nns=nns, dim1=dim1, dim2=dim2, &
+ nips=nips, val=obj%val, &
+ valStart=valStart, valEnd=valEnd, &
+ ansStart=ansStart, ansEnd=ansEnd)
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, &
+ nips=nips, dim1=dim1, &
+ dim2=dim2, val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd, &
+ ansStart=ansStart, &
+ ansEnd=ansEnd)
+
+END SELECT
+END PROCEDURE MatrixSpaceGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixSpaceGetInterpolation_3
+INTEGER(I4B) :: valEnd
+
+nrow = obj%s(1)
+ncol = obj%s(2)
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=scale, N=N, &
+ nns=nns, val=obj%val, &
+ dim1=nrow, dim2=ncol, &
+ valStart=0, valEnd=valEnd, &
+ spaceIndx=spaceIndx)
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, &
+ dim1=nrow, dim2=ncol, &
+ val=obj%val, &
+ spaceIndx=spaceIndx, &
+ valStart=0, valEnd=valEnd)
+
+END SELECT
+END PROCEDURE MatrixSpaceGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! Convert nodal values to quadrature values by using N
+! make sure nns .LE. obj%len
+! obj%s(1) denotes the nsd in ans
+! obj%s(2) should be atleast nns
+! obj%s(3) should be atleast nnt
+!
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_1
+INTEGER(I4B) :: aa, valStart, valEnd
+REAL(DFP) :: myscale
+
+dim1 = obj%s(1)
+dim2 = obj%s(2)
+dim3 = nips
+
+IF (.NOT. addContribution) ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ valEnd = 0
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = valEnd
+ CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=myscale, N=N, &
+ nns=nns, dim1=dim1, dim2=dim2, &
+ nips=nips, val=obj%val, &
+ valStart=valStart, valEnd=valEnd)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ valStart = nips * dim1 * dim2 * (timeIndx - 1)
+ CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, &
+ dim1=dim1, dim2=dim2, &
+ nips=nips, val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd)
+
+END SELECT
+END PROCEDURE MatrixSpaceTimeGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_2
+INTEGER(I4B) :: aa, valStart, valEnd, ansStart, ansEnd, dim1, dim2, dim3, &
+ tsize
+REAL(DFP) :: myscale
+
+dim1 = obj%s(1)
+dim2 = obj%s(2)
+dim3 = nips
+
+tsize = dim1 * dim2 * dim3
+ansStart = (timeIndx - 1) * tsize
+ansEnd = ansStart + tsize
+valStart = 0
+
+IF (.NOT. addContribution) ans%val(ansStart + 1:ansEnd) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ valEnd = 0
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = valEnd
+ CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=myscale, N=N, &
+ nns=nns, dim1=dim1, dim2=dim2, &
+ nips=nips, val=obj%val, &
+ valStart=valStart, valEnd=valEnd, &
+ ansStart=ansStart, ansEnd=ansEnd)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ valStart = tsize * (timeIndx - 1)
+ CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, &
+ dim1=dim1, dim2=dim2, &
+ nips=nips, val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd, &
+ ansStart=ansStart, &
+ ansEnd=ansEnd)
+
+END SELECT
+END PROCEDURE MatrixSpaceTimeGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixSpaceTimeGetInterpolation_3
+INTEGER(I4B) :: aa, valStart, valEnd
+REAL(DFP) :: myscale
+
+nrow = obj%s(1)
+ncol = obj%s(2)
+
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ valEnd = 0
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = valEnd
+ CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=myscale, N=N, &
+ nns=nns, dim1=nrow, dim2=ncol, &
+ spaceIndx=spaceIndx, val=obj%val, &
+ valStart=valStart, valEnd=valEnd)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ valStart = obj%s(3) * nrow * ncol * (timeIndx - 1)
+ CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, &
+ dim1=nrow, dim2=ncol, &
+ spaceIndx=spaceIndx, &
+ val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd)
+
+END SELECT
+END PROCEDURE MatrixSpaceTimeGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! MatrixInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MatrixGetInterpolation_3
+INTEGER(I4B) :: vartype
+vartype = obj%varType
+SELECT CASE (vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableConstant, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, &
+ addContribution=addContribution, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeFEVariableOpt%space)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableSpace, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, &
+ addContribution=addContribution, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeFEVariableOpt%time)
+
+CASE (TypeFEVariableOpt%spacetime)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableSpaceTime, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, &
+ addContribution=addContribution, ans=ans, nrow=nrow, ncol=ncol)
+END SELECT
+END PROCEDURE MatrixGetInterpolation_3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90
new file mode 100644
index 000000000..7ff5c9dba
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_MeanMethod@Methods.F90
@@ -0,0 +1,177 @@
+! 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(FEVariable_MeanMethod) Methods
+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 FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Addition
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Mean1
+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
+
+!----------------------------------------------------------------------------
+! Addition
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Mean2
+ans = SUM(obj%val(1:obj%len)) / obj%len
+END PROCEDURE fevar_Mean2
+
+!----------------------------------------------------------------------------
+! Addition
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Mean3
+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
+
+!----------------------------------------------------------------------------
+! Addition
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Mean4
+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
+ 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
+ END DO
+
+ ans = ans / (obj%s(3) * obj%s(4))
+
+END SELECT
+
+END PROCEDURE fevar_Mean4
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90
deleted file mode 100644
index baa59dc5d..000000000
--- a/src/submodules/FEVariable/src/FEVariable_Method@ConstructorMethods.F90
+++ /dev/null
@@ -1,323 +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(FEVariable_Method) ConstructorMethods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! Deallocate
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_Deallocate
-IF (ALLOCATED(obj%val)) DEALLOCATE (obj%val)
-obj%s = 0
-obj%DefineOn = 0
-obj%VarType = 0
-obj%Rank = 0
-END PROCEDURE fevar_Deallocate
-
-!----------------------------------------------------------------------------
-! NodalVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Nodal_Scalar_Constant
-obj%val = [val]
-obj%s = 0
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = CONSTANT
-END PROCEDURE Nodal_Scalar_Constant
-
-!----------------------------------------------------------------------------
-! NodalVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Nodal_Scalar_Space
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = SPACE
-END PROCEDURE Nodal_Scalar_Space
-
-!----------------------------------------------------------------------------
-! NodalVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Nodal_Scalar_Time
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = NODAL
-obj%rank = SCALAR
-obj%vartype = TIME
-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
-
-!----------------------------------------------------------------------------
-! NodalVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Nodal_Vector_Constant
-obj%val = val
-obj%s(1:1) = SHAPE(val)
-obj%defineon = NODAL
-obj%rank = VECTOR
-obj%vartype = CONSTANT
-END PROCEDURE Nodal_Vector_Constant
-
-!----------------------------------------------------------------------------
-! NodalVariable
-!----------------------------------------------------------------------------
-
-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
-END PROCEDURE Nodal_Vector_Space
-
-!----------------------------------------------------------------------------
-! 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
-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
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Nodal_Matrix_Constant
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Nodal_Matrix_Space
-
-!----------------------------------------------------------------------------
-! 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
-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
-
-!----------------------------------------------------------------------------
-! QuadratureVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Quadrature_Scalar_Constant
-obj%val = [val]
-obj%s = 0
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = CONSTANT
-END PROCEDURE Quadrature_Scalar_Constant
-
-!----------------------------------------------------------------------------
-! QuadratureVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Quadrature_Scalar_Space
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = SPACE
-END PROCEDURE Quadrature_Scalar_Space
-
-!----------------------------------------------------------------------------
-! QuadratureVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Quadrature_Scalar_Time
-obj%val = val
-obj%s(1) = SIZE(val)
-obj%defineon = Quadrature
-obj%rank = SCALAR
-obj%vartype = TIME
-END PROCEDURE Quadrature_Scalar_Time
-
-!----------------------------------------------------------------------------
-! 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
-
-!----------------------------------------------------------------------------
-! QuadratureVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Quadrature_Vector_Constant
-obj%val = val
-obj%s(1:1) = SHAPE(val)
-obj%defineon = Quadrature
-obj%rank = VECTOR
-obj%vartype = CONSTANT
-END PROCEDURE Quadrature_Vector_Constant
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Quadrature_Vector_Space
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Quadrature_Vector_Time
-
-!----------------------------------------------------------------------------
-! 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
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Quadrature_Matrix_Constant
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Quadrature_Matrix_Space
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE Quadrature_Matrix_Time
-
-!----------------------------------------------------------------------------
-! 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
-
-END SUBMODULE ConstructorMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90
deleted file mode 100644
index a1b1f1ab1..000000000
--- a/src/submodules/FEVariable/src/FEVariable_Method@DotProductMethods.F90
+++ /dev/null
@@ -1,282 +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(FEVariable_Method) DotProductMethods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! DOT_PRODUCT
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_dot_product
-!! Internal variable
-REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:,:), r3(:, :, :), m3(:,:,:)
-INTEGER(I4B) :: jj, kk
-!!
-!! main
-!!
-SELECT CASE (obj1%vartype)
-!!
-!!
-!!
-!!
-CASE (constant)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! constant = constant DOT_PRODUCT constant
- !!
- CASE (constant)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & DOT_PRODUCT(obj1%val(:), obj2%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- ELSE
- ans = QuadratureVariable( &
- & DOT_PRODUCT(obj1%val(:), obj2%val(:)), &
- & typeFEVariableScalar, &
- & typeFEVariableConstant)
- END IF
- !!
- !! space= constant DOT_PRODUCT space
- !!
- CASE (space)
- !!
- r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & MATMUL(obj1%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & MATMUL(obj1%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
- !!
- !! time=constant DOT_PRODUCT time
- !!
- CASE (time)
- !!
- r2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & MATMUL(obj1%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & MATMUL(obj1%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
- !!
- !! spacetime=constant DOT_PRODUCT spacetime
- !!
- CASE (spacetime)
- !!
- r3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime)
- !!
- IF( obj2%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & MATMUL(obj1%val, r3), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & MATMUL(obj1%val, r3), &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (space)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! space=space DOT_PRODUCT constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & MATMUL(obj2%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable(&
- & MATMUL(obj2%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
- !!
- !! space=space DOT_PRODUCT space
- !!
- CASE (space)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpace)
- m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpace)
- CALL Reallocate(r1, size(r2, 2))
- !!
- DO jj = 1, size(r1)
- r1( jj ) = DOT_PRODUCT(r2(:, jj), m2(:, jj))
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- ans = QuadratureVariable( &
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- END IF
- !!
- END SELECT
-!!
-!!
-!!
-!!
-CASE (time)
-!!
- SELECT CASE (obj2%vartype)
- !!
- !! time=time DOT_PRODUCT constant
- !!
- CASE (constant)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & MATMUL(obj2%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & MATMUL(obj2%val, r2), &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
- !!
- !! time=time DOT_PRODUCT time
- !!
- CASE (time)
- !!
- r2 = GET(obj1, TypeFEVariableVector, TypeFEVariableTime)
- m2 = GET(obj2, TypeFEVariableVector, TypeFEVariableTime)
- CALL Reallocate(r1, size(r2, 2))
- !!
- DO jj = 1, size(r1)
- r1( jj ) = DOT_PRODUCT(r2(:, jj), m2(:, jj))
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable( &
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable( &
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
- !!
- END SELECT
-!!
-CASE (spacetime)
- !!
- SELECT CASE (obj2%vartype)
- !!
- !! spacetime= spacetime DOT_PRODUCT constant
- !!
- CASE (constant)
- !!
- r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime)
- CALL Reallocate( r2, size(r3,2), size(r3,3) )
- !!
- DO kk = 1, SIZE(r3, 3)
- DO jj = 1, SIZE(r3, 2)
- r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), obj2%val(:))
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- !! spacetime=spacetime DOT_PRODUCT spacetime
- !!
- CASE (spacetime)
- !!
- r3 = GET(obj1, TypeFEVariableVector, TypeFEVariableSpaceTime)
- m3 = GET(obj2, TypeFEVariableVector, TypeFEVariableSpaceTime)
- !!
- CALL Reallocate( r2, size(r3,2), size(r3,3) )
- !!
- DO kk = 1, SIZE(r3, 3)
- DO jj = 1, SIZE(r3, 2)
- r2(jj, kk) = DOT_PRODUCT(r3(:, jj, kk), m3(:,jj,kk))
- END DO
- END DO
- !!
- IF( obj1%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
- END SELECT
- !!
-END SELECT
-END PROCEDURE fevar_dot_product
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE DotProductMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90
deleted file mode 100644
index fe72dd320..000000000
--- a/src/submodules/FEVariable/src/FEVariable_Method@GetMethods.F90
+++ /dev/null
@@ -1,255 +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(FEVariable_Method) GetMethods
-USE BaseMethod, ONLY: Reallocate
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! GetLambdaFromYoungsModulus
-!----------------------------------------------------------------------------
-
-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
-
-CALL Reallocate(lambda%val, tsize)
-
-DO ii = 1, tsize
- lambda%val(1:tsize) = shearModulus%val * &
- & (youngsModulus%val - 2.0_DFP * shearModulus%val) / &
- & (3.0_DFP * shearModulus%val - youngsModulus%val)
-END DO
-
-lambda%s = youngsModulus%s
-lambda%defineOn = youngsModulus%defineOn
-lambda%varType = youngsModulus%varType
-lambda%rank = youngsModulus%rank
-END PROCEDURE fevar_GetLambdaFromYoungsModulus
-
-!----------------------------------------------------------------------------
-! Size
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_Size
-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
-END IF
-END PROCEDURE fevar_Size
-
-!----------------------------------------------------------------------------
-! Shape
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_Shape
-SELECT CASE (obj%rank)
-CASE (Scalar)
- SELECT CASE (obj%vartype)
- CASE (Constant)
- ans = [1]
- CASE (Space, Time)
- ans = obj%s(1:1)
- CASE (SpaceTime)
- ans = obj%s(1:2)
- END SELECT
-CASE (Vector)
- SELECT CASE (obj%vartype)
- CASE (Constant)
- ans = obj%s(1:1)
- CASE (Space, Time)
- ans = obj%s(1:2)
- CASE (SpaceTime)
- ans = obj%s(1:3)
- END SELECT
-CASE (Matrix)
- SELECT CASE (obj%vartype)
- CASE (Constant)
- ans = obj%s(1:2)
- CASE (Space, Time)
- ans = obj%s(1:3)
- CASE (SpaceTime)
- ans = obj%s(1:4)
- END SELECT
-END SELECT
-END PROCEDURE fevar_Shape
-
-!----------------------------------------------------------------------------
-! rank
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_rank
-ans = obj%rank
-END PROCEDURE fevar_rank
-
-!----------------------------------------------------------------------------
-! vartype
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_vartype
-ans = obj%vartype
-END PROCEDURE fevar_vartype
-
-!----------------------------------------------------------------------------
-! defineon
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_defineon
-ans = obj%defineon
-END PROCEDURE fevar_defineon
-
-!----------------------------------------------------------------------------
-! isNodalVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_isNodalVariable
-IF (obj%defineon .EQ. nodal) THEN
- ans = .TRUE.
-ELSE
- ans = .FALSE.
-END IF
-END PROCEDURE fevar_isNodalVariable
-
-!----------------------------------------------------------------------------
-! isNodalVariable
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_isQuadratureVariable
-IF (obj%defineon .EQ. nodal) THEN
- ans = .FALSE.
-ELSE
- ans = .TRUE.
-END IF
-END PROCEDURE fevar_isQuadratureVariable
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Scalar_Constant
-val = obj%val(1)
-END PROCEDURE Scalar_Constant
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Scalar_Space
-val = obj%val
-END PROCEDURE Scalar_Space
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Scalar_Time
-val = obj%val
-END PROCEDURE Scalar_Time
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Scalar_SpaceTime
-val = RESHAPE(obj%val, obj%s(1:2))
-END PROCEDURE Scalar_SpaceTime
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Vector_Constant
-val = obj%val
-END PROCEDURE Vector_Constant
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Vector_Space
-val = RESHAPE(obj%val, obj%s(1:2))
-END PROCEDURE Vector_Space
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Vector_Time
-val = RESHAPE(obj%val, obj%s(1:2))
-END PROCEDURE Vector_Time
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Vector_SpaceTime
-val = RESHAPE(obj%val, obj%s(1:3))
-END PROCEDURE Vector_SpaceTime
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Matrix_Constant
-val = RESHAPE(obj%val, obj%s(1:2))
-END PROCEDURE Matrix_Constant
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Matrix_Space
-val = RESHAPE(obj%val, obj%s(1:3))
-END PROCEDURE Matrix_Space
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Matrix_Time
-val = RESHAPE(obj%val, obj%s(1:3))
-END PROCEDURE Matrix_Time
-
-!----------------------------------------------------------------------------
-! getNodalvalues
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Matrix_SpaceTime
-val = RESHAPE(obj%val, obj%s(1:4))
-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
deleted file mode 100644
index 8afea2cb1..000000000
--- a/src/submodules/FEVariable/src/FEVariable_Method@IOMethods.F90
+++ /dev/null
@@ -1,121 +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(FEVariable_Method) IOMethods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! Display
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_Display
-!!
-!! main
-!!
-CALL 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)
- 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)
- 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)
- END SELECT
-END SELECT
-!!
-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
deleted file mode 100644
index e136ab97b..000000000
--- a/src/submodules/FEVariable/src/FEVariable_Method@MeanMethods.F90
+++ /dev/null
@@ -1,181 +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(FEVariable_Method) MeanMethods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! Addition
-!----------------------------------------------------------------------------
-
-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
- !!
-END PROCEDURE fevar_Mean1
-
-!----------------------------------------------------------------------------
-! Addition
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_Mean2
- REAL( DFP ) :: val0
- !!
- ans = SUM( obj%val( : ) ) / SIZE( obj%val )
- !!
-END PROCEDURE fevar_Mean2
-
-!----------------------------------------------------------------------------
-! Addition
-!----------------------------------------------------------------------------
-
-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 )
- !!
-END PROCEDURE fevar_Mean3
-
-!----------------------------------------------------------------------------
-! Addition
-!----------------------------------------------------------------------------
-
-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 )
- 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
- END DO
- !!
- ans = ans / obj%s(3) / obj%s(4)
- !!
- END SELECT
- !!
- IF( ALLOCATED( val3 ) ) DEALLOCATE( val3 )
- IF( ALLOCATED( val4 ) ) DEALLOCATE( val4 )
- !!
-END PROCEDURE fevar_Mean4
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE MeanMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90 b/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90
deleted file mode 100644
index 0306feadb..000000000
--- a/src/submodules/FEVariable/src/FEVariable_Method@Norm2Methods.F90
+++ /dev/null
@@ -1,136 +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(FEVariable_Method) Norm2Methods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! NORM2
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_norm2
-!! Internal variable
-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)
- ELSE
- ans = QuadratureVariable( &
- & NORM2(obj%val(:)), &
- & 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))
- END DO
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableSpace)
- ELSE
- 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))
- END DO
- !!
- IF( obj%defineon .EQ. nodal ) THEN
- ans = NodalVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- ELSE
- ans = QuadratureVariable(&
- & r1, &
- & typeFEVariableScalar, &
- & typeFEVariableTime)
- END IF
-!!
-!!
-!!
-!!
-CASE (spacetime)
- !!
- r3 = GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime)
- 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)
- ELSE
- ans = QuadratureVariable(&
- & r2, &
- & typeFEVariableScalar, &
- & typeFEVariableSpaceTime)
- END IF
- !!
-END SELECT
-!!
-!!
-!!
-!!
-END PROCEDURE fevar_norm2
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE Norm2Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90 b/src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90
similarity index 55%
rename from src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90
rename to src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90
index 2ce794012..348971c5c 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@MultiplicationMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_MultiplicationMethod@Methods.F90
@@ -14,11 +14,27 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
+
+SUBMODULE(FEVariable_MultiplicationMethod) Methods
+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
+
+USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+
#define _OP_ *
-SUBMODULE(FEVariable_Method) MultiplicationMethods
-USE BaseMethod
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
@@ -26,62 +42,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 +77,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 +92,19 @@
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 Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90
new file mode 100644
index 000000000..74f844b55
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_NodalVariableMethod@Methods.F90
@@ -0,0 +1,565 @@
+! 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(FEVariable_NodalVariableMethod) Methods
+USE ReallocateUtility, ONLY: Reallocate
+USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_Constant
+INTEGER(I4B) :: s(1)
+
+s(1) = 1
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%scalar, len=1)
+obj%val(1) = val
+END PROCEDURE Nodal_Scalar_Constant
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_Space
+INTEGER(I4B) :: s(1)
+
+s(1) = SIZE(val)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+obj%val(1:obj%len) = val
+END PROCEDURE Nodal_Scalar_Space
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_Space2
+INTEGER(I4B) :: s(1)
+
+s(1) = tsize
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+obj%val(1:obj%len) = 0.0_DFP
+END PROCEDURE Nodal_Scalar_Space2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_Time
+INTEGER(I4B) :: s(1)
+
+s(1) = SIZE(val)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+obj%val(1:obj%len) = val
+END PROCEDURE Nodal_Scalar_Time
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_Time2
+INTEGER(I4B) :: s(1)
+
+s(1) = tsize
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+END PROCEDURE Nodal_Scalar_Time2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_SpaceTime
+INTEGER(I4B) :: s(2), tsize, ii, jj, kk
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%scalar, len=tsize)
+
+kk = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ kk = kk + 1
+ obj%val(kk) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Nodal_Scalar_SpaceTime
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_SpaceTime2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%scalar, len=tsize, &
+ val=val)
+END PROCEDURE Nodal_Scalar_SpaceTime2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Scalar_SpaceTime3
+INTEGER(I4B) :: tsize, s(2)
+
+s(1) = nrow
+s(2) = ncol
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%scalar, len=tsize)
+END PROCEDURE Nodal_Scalar_SpaceTime3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Constant
+INTEGER(I4B) :: s(1), tsize
+
+tsize = SIZE(val)
+s(1) = tsize
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%vector, len=tsize, &
+ val=val)
+END PROCEDURE Nodal_Vector_Constant
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Constant2
+INTEGER(I4B) :: s(1)
+
+s(1) = tsize
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+END PROCEDURE Nodal_Vector_Constant2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Space
+INTEGER(I4B) :: s(2), tsize, ii, jj, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+cnt = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Nodal_Vector_Space
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Space2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%vector, len=tsize, val=val)
+
+END PROCEDURE Nodal_Vector_Space2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Space3
+INTEGER(I4B) :: s(2), tsize
+
+s(1) = nrow
+s(2) = ncol
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+END PROCEDURE Nodal_Vector_Space3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Time
+INTEGER(I4B) :: s(2), tsize, ii, jj, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+cnt = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Nodal_Vector_Time
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Time2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%vector, len=tsize, val=val)
+END PROCEDURE Nodal_Vector_Time2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_Time3
+INTEGER(I4B) :: tsize, s(2)
+
+s(1) = nrow
+s(2) = ncol
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+END PROCEDURE Nodal_Vector_Time3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_SpaceTime
+INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+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
+END PROCEDURE Nodal_Vector_SpaceTime
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_SpaceTime2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%vector, len=tsize, &
+ val=val)
+END PROCEDURE Nodal_Vector_SpaceTime2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Vector_SpaceTime3
+INTEGER(I4B) :: tsize, s(3)
+
+s(1) = dim1
+s(2) = dim2
+s(3) = dim3
+tsize = s(1) * s(2) * s(3)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+END PROCEDURE Nodal_Vector_SpaceTime3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Constant
+INTEGER(I4B) :: s(2), tsize, ii, jj, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+cnt = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Nodal_Matrix_Constant
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Constant2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%matrix, len=tsize, val=val)
+END PROCEDURE Nodal_Matrix_Constant2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Constant3
+INTEGER(I4B) :: s(2), tsize
+
+s(1) = nrow
+s(2) = ncol
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+END PROCEDURE Nodal_Matrix_Constant3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Space
+INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+cnt = 0
+DO kk = 1, s(3)
+ DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj, kk)
+ END DO
+ END DO
+END DO
+END PROCEDURE Nodal_Matrix_Space
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Space2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%matrix, &
+ len=tsize, val=val)
+END PROCEDURE Nodal_Matrix_Space2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Space3
+INTEGER(I4B) :: tsize, s(3)
+
+s(1) = dim1
+s(2) = dim2
+s(3) = dim3
+
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+END PROCEDURE Nodal_Matrix_Space3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Time
+INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+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
+END PROCEDURE Nodal_Matrix_Time
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Time2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2) * s(3)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%matrix, &
+ len=tsize, val=val)
+END PROCEDURE Nodal_Matrix_Time2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_Time3
+INTEGER(I4B) :: tsize, s(3)
+
+s(1) = dim1
+s(2) = dim2
+s(3) = dim3
+
+tsize = s(1) * s(2) * s(3)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+END PROCEDURE Nodal_Matrix_Time3
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_SpaceTime
+INTEGER(I4B) :: s(4), tsize, ii, jj, kk, ll, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3) * s(4)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+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
+END PROCEDURE Nodal_Matrix_SpaceTime
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_SpaceTime2
+INTEGER(I4B) :: tsize
+
+tsize = PRODUCT(s)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%matrix, len=tsize, val=val)
+END PROCEDURE Nodal_Matrix_SpaceTime2
+
+!----------------------------------------------------------------------------
+! NodalVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Nodal_Matrix_SpaceTime3
+INTEGER(I4B) :: tsize, s(4)
+
+s(1) = dim1
+s(2) = dim2
+s(3) = dim3
+s(4) = dim4
+tsize = PRODUCT(s)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%nodal, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+END PROCEDURE Nodal_Matrix_SpaceTime3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90
new file mode 100644
index 000000000..3b4327b2d
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_QuadratureVariableMethod@Methods.F90
@@ -0,0 +1,472 @@
+! 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(FEVariable_QuadratureVariableMethod) Methods
+USE ReallocateUtility, ONLY: Reallocate
+USE FEVariable_ConstructorMethod, ONLY: FEVariableInitiate => Initiate
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_Constant
+INTEGER(I4B) :: s(1)
+
+s(1) = 1
+CALL FEVariableInitiate(obj=obj, s=s, &
+ defineon=TypeFEVariableOpt%quadrature, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%scalar, len=1)
+obj%val(1) = val
+END PROCEDURE Quadrature_Scalar_Constant
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_Space
+INTEGER(I4B) :: s(1)
+
+s(1) = SIZE(val)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+obj%val(1:obj%len) = val
+END PROCEDURE Quadrature_Scalar_Space
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_Space2
+INTEGER(I4B) :: s(1)
+
+s(1) = tsize
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+obj%val(1:obj%len) = 0.0_DFP
+END PROCEDURE Quadrature_Scalar_Space2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_Time
+INTEGER(I4B) :: s(1)
+
+s(1) = SIZE(val)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%scalar, len=s(1))
+obj%val(1:obj%len) = val
+END PROCEDURE Quadrature_Scalar_Time
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_Time2
+INTEGER(I4B) :: s(1)
+
+s(1) = tsize
+CALL FEVariableInitiate( &
+ obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, len=s(1), &
+ vartype=TypeFEVariableOpt%time, rank=TypeFEVariableOpt%scalar)
+obj%val(1:obj%len) = 0.0_DFP
+END PROCEDURE Quadrature_Scalar_Time2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_SpaceTime
+INTEGER(I4B) :: s(2), tsize, ii, jj, kk
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%scalar, len=tsize)
+
+kk = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ kk = kk + 1
+ obj%val(kk) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Quadrature_Scalar_SpaceTime
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_SpaceTime2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate( &
+ obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, len=tsize, val=val, &
+ vartype=TypeFEVariableOpt%spacetime, rank=TypeFEVariableOpt%scalar)
+END PROCEDURE Quadrature_Scalar_SpaceTime2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Scalar_SpaceTime3
+INTEGER(I4B) :: tsize, s(2)
+
+s(1) = nrow
+s(2) = ncol
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate( &
+ obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, len=tsize, &
+ vartype=TypeFEVariableOpt%spacetime, rank=TypeFEVariableOpt%scalar)
+END PROCEDURE Quadrature_Scalar_SpaceTime3
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Constant
+INTEGER(I4B) :: s(1), tsize
+
+tsize = SIZE(val)
+s(1) = tsize
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%vector, len=tsize, &
+ val=val)
+END PROCEDURE Quadrature_Vector_Constant
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Space
+INTEGER(I4B) :: s(2), tsize, ii, jj, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+cnt = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Quadrature_Vector_Space
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Space2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%vector, len=tsize, val=val)
+
+END PROCEDURE Quadrature_Vector_Space2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Space3
+INTEGER(I4B) :: s(2), tsize
+
+s(1) = nrow
+s(2) = ncol
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+obj%val(1:obj%len) = 0.0_DFP
+END PROCEDURE Quadrature_Vector_Space3
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Time
+INTEGER(I4B) :: s(2), tsize, ii, jj, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+cnt = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+END PROCEDURE Quadrature_Vector_Time
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_Time2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%vector, len=tsize, val=val)
+
+END PROCEDURE Quadrature_Vector_Time2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_SpaceTime
+INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+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
+END PROCEDURE Quadrature_Vector_SpaceTime
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_SpaceTime2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%vector, len=tsize, &
+ val=val)
+END PROCEDURE Quadrature_Vector_SpaceTime2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Vector_SpaceTime3
+INTEGER(I4B) :: tsize, s(3)
+
+s(1) = dim1
+s(2) = dim2
+s(3) = dim3
+tsize = dim1 * dim2 * dim3
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%vector, len=tsize)
+
+END PROCEDURE Quadrature_Vector_SpaceTime3
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Constant
+INTEGER(I4B) :: s(2), tsize, ii, jj, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+cnt = 0
+DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj)
+ END DO
+END DO
+
+END PROCEDURE Quadrature_Matrix_Constant
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Constant2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%constant, &
+ rank=TypeFEVariableOpt%matrix, len=tsize, val=val)
+END PROCEDURE Quadrature_Matrix_Constant2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Space
+INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+cnt = 0
+DO kk = 1, s(3)
+ DO jj = 1, s(2)
+ DO ii = 1, s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = val(ii, jj, kk)
+ END DO
+ END DO
+END DO
+END PROCEDURE Quadrature_Matrix_Space
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Space2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2) * s(3)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%space, &
+ rank=TypeFEVariableOpt%matrix, &
+ len=tsize, val=val)
+END PROCEDURE Quadrature_Matrix_Space2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Time
+INTEGER(I4B) :: s(3), tsize, ii, jj, kk, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+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
+END PROCEDURE Quadrature_Matrix_Time
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_Time2
+INTEGER(I4B) :: tsize
+
+tsize = s(1) * s(2) * s(3)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%time, &
+ rank=TypeFEVariableOpt%matrix, &
+ len=tsize, val=val)
+
+END PROCEDURE Quadrature_Matrix_Time2
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_SpaceTime
+INTEGER(I4B) :: s(4), tsize, ii, jj, kk, ll, cnt
+
+s = SHAPE(val)
+tsize = s(1) * s(2) * s(3) * s(4)
+
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%matrix, len=tsize)
+
+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
+END PROCEDURE Quadrature_Matrix_SpaceTime
+
+!----------------------------------------------------------------------------
+! QuadratureVariable
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Quadrature_Matrix_SpaceTime2
+INTEGER(I4B) :: tsize
+
+tsize = PRODUCT(s)
+CALL FEVariableInitiate(obj=obj, s=s, defineon=TypeFEVariableOpt%Quadrature, &
+ vartype=TypeFEVariableOpt%spacetime, &
+ rank=TypeFEVariableOpt%matrix, len=tsize, val=val)
+END PROCEDURE Quadrature_Matrix_SpaceTime2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90
new file mode 100644
index 000000000..97c1e39dd
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_ScalarInterpolationMethod@Methods.F90
@@ -0,0 +1,347 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_ScalarInterpolationMethod) Methods
+USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, &
+ TypeFEVariableSpaceTime, TypeFEVariableTime
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarConstantGetInterpolation_1
+INTEGER(I4B) :: ii
+
+tsize = nips
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+
+DO ii = 1, tsize
+ ans(ii) = ans(ii) + scale * obj%val(1)
+END DO
+END PROCEDURE ScalarConstantGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarConstantGetInterpolation_2
+INTEGER(I4B) :: ii, ansStart
+
+ansStart = (timeIndx - 1) * ans%s(1)
+IF (.NOT. addContribution) ans%val(ansStart + 1:ansStart + nips) = 0.0_DFP
+
+DO ii = 1, nips
+ ans%val(ansStart + ii) = ans%val(ansStart + ii) + scale * obj%val(1)
+END DO
+END PROCEDURE ScalarConstantGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarConstantGetInterpolation_3
+IF (.NOT. addContribution) ans = 0.0_DFP
+ans = ans + scale * obj%val(1)
+END PROCEDURE ScalarConstantGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolation1_(ans, scale, N, nns, nips, val, &
+ valStart, ansStart)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart, ansStart
+
+ INTEGER(I4B) :: ips, ii
+
+ DO ips = 1, nips
+ DO ii = 1, nns
+ ans(ansStart + ips) = ans(ansStart + ips) &
+ + scale * N(ii, ips) * val(valStart + ii)
+ END DO
+ END DO
+
+END SUBROUTINE MasterGetInterpolation1_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolation3_(ans, scale, N, nns, spaceIndx, val, &
+ valStart)
+ REAL(DFP), INTENT(INOUT) :: ans
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, spaceIndx
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+
+ INTEGER(I4B) :: ii
+
+ DO ii = 1, nns
+ ans = ans + scale * N(ii, spaceIndx) * val(valStart + ii)
+ END DO
+END SUBROUTINE MasterGetInterpolation3_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarSpaceGetInterpolation_1
+INTEGER(I4B) :: ips
+
+tsize = nips
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ !! convert nodal values to quadrature values by using N
+ !! make sure nns .LE. obj%len
+
+ CALL MasterGetInterpolation1_(ans=ans, scale=scale, N=N, nns=nns, &
+ nips=nips, val=obj%val, valStart=0, &
+ ansStart=0)
+
+CASE (TypeFEVariableOpt%quadrature)
+ !! No need for interpolation, just returnt the quadrature values
+ !! make sure nips .LE. obj%len
+
+ DO ips = 1, tsize
+ ans(ips) = ans(ips) + scale * obj%val(ips)
+ END DO
+
+END SELECT
+
+END PROCEDURE ScalarSpaceGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarSpaceGetInterpolation_2
+INTEGER(I4B) :: ips, ansStart, valStart
+
+ansStart = (timeIndx - 1) * ans%s(1)
+valStart = 0
+
+IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ CALL MasterGetInterpolation1_(ans=ans%val, scale=scale, N=N, &
+ nns=nns, nips=nips, val=obj%val, &
+ valStart=valStart, ansStart=ansStart)
+
+ ans%s(1) = nips
+ ans%len = nips
+
+CASE (TypeFEVariableOpt%quadrature)
+ DO ips = 1, nips
+ ans%val(ansStart + ips) = ans%val(ansStart + ips) + scale * obj%val(ips)
+ END DO
+
+END SELECT
+
+END PROCEDURE ScalarSpaceGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! obj%defineon is nodal
+! convert nodal values to quadrature values by using N
+! make sure nns .LE. obj%len
+!
+! obj%defineon is quadrature
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+MODULE PROCEDURE ScalarSpaceGetInterpolation_3
+IF (.NOT. addContribution) ans = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ CALL MasterGetInterpolation3_(ans=ans, scale=scale, N=N, nns=nns, &
+ spaceIndx=spaceIndx, val=obj%val, valStart=0)
+
+CASE (TypeFEVariableOpt%quadrature)
+ ans = ans + scale * obj%val(spaceIndx)
+
+END SELECT
+END PROCEDURE ScalarSpaceGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_1
+INTEGER(I4B) :: aa, valStart, ansStart
+REAL(DFP) :: myscale
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+
+tsize = nips
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+
+ansStart = 0
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ !! convert nodal values to quadrature values by using N
+ !! make sure nns .LE. obj%len
+ !! obj%s(1) should be atleast nns
+ !! obj%s(2) should be atleast nnt
+
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = (aa - 1) * obj%s(1)
+ CALL MasterGetInterpolation1_(ans=ans, scale=myscale, N=N, nns=nns, &
+ nips=nips, val=obj%val, valStart=valStart, &
+ ansStart=ansStart)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+ !! No need for interpolation, just returnt the quadrature values
+ !! make sure nips .LE. obj%len
+
+ valStart = (timeIndx - 1) * obj%s(1)
+ DO aa = 1, tsize
+ ans(aa) = ans(aa) + scale * obj%val(valStart + aa)
+ END DO
+
+END SELECT
+
+END PROCEDURE ScalarSpaceTimeGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_2
+INTEGER(I4B) :: aa, valStart, ansStart
+REAL(DFP) :: myscale
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+
+ansStart = (timeIndx - 1) * ans%s(1)
+IF (.NOT. addContribution) ans%val(1 + ansStart:nips + ansStart) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+
+CASE (TypeFEVariableOpt%nodal)
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = (aa - 1) * obj%s(1)
+ CALL MasterGetInterpolation1_(ans=ans%val, scale=myscale, N=N, nns=nns, &
+ nips=nips, val=obj%val, valStart=valStart, &
+ ansStart=ansStart)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+ valStart = (timeIndx - 1) * obj%s(1)
+ DO aa = 1, nips
+ ans%val(ansStart + aa) = ans%val(ansStart + aa) &
+ + scale * obj%val(valStart + aa)
+ END DO
+
+END SELECT
+
+END PROCEDURE ScalarSpaceTimeGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! obj%defineon is nodal
+! convert nodal values to quadrature values by using N
+! make sure nns .LE. obj%len
+! obj%s(1) should be atleast nns
+! obj%s(2) should be atleast nnt
+!
+! obj%defineon is quadrature
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+
+MODULE PROCEDURE ScalarSpaceTimeGetInterpolation_3
+INTEGER(I4B) :: aa, valStart
+REAL(DFP) :: myscale
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+
+IF (.NOT. addContribution) ans = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+
+CASE (TypeFEVariableOpt%nodal)
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = (aa - 1) * obj%s(1)
+ CALL MasterGetInterpolation3_(ans=ans, scale=myscale, N=N, nns=nns, &
+ spaceIndx=spaceIndx, val=obj%val, &
+ valStart=valStart)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+ valStart = (timeIndx - 1) * obj%s(1)
+ ans = ans + scale * obj%val(valStart + spaceIndx)
+
+END SELECT
+END PROCEDURE ScalarSpaceTimeGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ScalarGetInterpolation_3
+INTEGER(I4B) :: vartype
+
+vartype = obj%varType
+
+SELECT CASE (vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableConstant, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, &
+ addContribution=addContribution, ans=ans)
+
+CASE (TypeFEVariableOpt%space)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableSpace, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, &
+ addContribution=addContribution, ans=ans)
+
+CASE (TypeFEVariableOpt%time)
+ ! CALL GetInterpolation_( &
+ ! obj=obj, rank=rank, N=N, nns=nns, spaceIndx=spaceIndx, &
+ ! timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, &
+ ! addContribution=addContribution, ans=ans)
+
+CASE (TypeFEVariableOpt%spacetime)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableSpaceTime, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, &
+ addContribution=addContribution, ans=ans)
+
+END SELECT
+
+END PROCEDURE ScalarGetInterpolation_3
+
+END SUBMODULE Methods
diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90
new file mode 100644
index 000000000..5349d382f
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@MatrixMethods.F90
@@ -0,0 +1,155 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_SetMethod) MatrixMethods
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set7
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%s(1:2) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2)
+
+cnt = 0
+
+IF (addContribution) THEN
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj)
+ END DO
+ END DO
+ELSE
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj)
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set7
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set8
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%s(1:3) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2) * obj%s(3)
+
+cnt = 0
+IF (addContribution) THEN
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk)
+ END DO
+ END DO
+ END DO
+ELSE
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj, kk)
+ END DO
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set8
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set9
+INTEGER(I4B) :: ii, jj, kk, ll, cnt
+
+obj%s(1:4) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2) * obj%s(3) * obj%s(4)
+
+cnt = 0
+IF (addContribution) THEN
+ 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
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk, ll)
+ END DO
+ END DO
+ END DO
+ END DO
+ELSE
+ 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
+ obj%val(cnt) = scale * val(ii, jj, kk, ll)
+ END DO
+ END DO
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set9
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set12
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%s(1:3) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2) * obj%s(3)
+
+cnt = 0
+IF (addContribution) THEN
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk)
+ END DO
+ END DO
+ END DO
+ELSE
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj, kk)
+ END DO
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set12
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE MatrixMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90
new file mode 100644
index 000000000..54ca3060d
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@ScalarMethods.F90
@@ -0,0 +1,98 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_SetMethod) ScalarMethods
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set1
+obj%len = 1
+obj%s(1) = obj%len
+IF (addContribution) THEN
+ obj%val(1) = obj%val(1) + scale * val
+ELSE
+ obj%val(1) = scale * val
+END IF
+END PROCEDURE obj_Set1
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set2
+obj%len = SIZE(val)
+obj%s(1) = obj%len
+IF (addContribution) THEN
+ obj%val(1:obj%len) = obj%val(1:obj%len) + scale * val(1:obj%len)
+ELSE
+ obj%val(1:obj%len) = scale * val(1:obj%len)
+END IF
+END PROCEDURE obj_Set2
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set3
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%s(1:2) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2)
+
+cnt = 0
+
+IF (addContribution) THEN
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj)
+ END DO
+ END DO
+ELSE
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj)
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set3
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set10
+obj%len = SIZE(val)
+obj%s(1) = obj%len
+IF (addContribution) THEN
+ obj%val(1:obj%len) = obj%val(1:obj%len) + scale * val(1:obj%len)
+ELSE
+ obj%val(1:obj%len) = scale * val(1:obj%len)
+END IF
+END PROCEDURE obj_Set10
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE ScalarMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90
new file mode 100644
index 000000000..1d26f32cf
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_SetMethod@VectorMethods.F90
@@ -0,0 +1,131 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_SetMethod) VectorMethods
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set4
+obj%len = SIZE(val)
+obj%s(1) = SIZE(val)
+IF (addContribution) THEN
+ obj%val(1:obj%len) = obj%val(1:obj%len) + scale * val(1:obj%len)
+ELSE
+ obj%val(1:obj%len) = scale * val(1:obj%len)
+END IF
+END PROCEDURE obj_Set4
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set5
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%s(1:2) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2)
+
+cnt = 0
+
+IF (addContribution) THEN
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj)
+ END DO
+ END DO
+ELSE
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj)
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set5
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set6
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%s(1:3) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2) * obj%s(3)
+
+cnt = 0
+IF (addContribution) THEN
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj, kk)
+ END DO
+ END DO
+ END DO
+ELSE
+ DO kk = 1, obj%s(3)
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj, kk)
+ END DO
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set6
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set11
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%s(1:2) = SHAPE(val)
+obj%len = obj%s(1) * obj%s(2)
+
+cnt = 0
+
+IF (addContribution) THEN
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = obj%val(cnt) + scale * val(ii, jj)
+ END DO
+ END DO
+ELSE
+ DO jj = 1, obj%s(2)
+ DO ii = 1, obj%s(1)
+ cnt = cnt + 1
+ obj%val(cnt) = scale * val(ii, jj)
+ END DO
+ END DO
+END IF
+END PROCEDURE obj_Set11
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE VectorMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90 b/src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90
similarity index 56%
rename from src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90
rename to src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90
index 7ce5b3cef..809c3a34b 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@SubtractionMethods.F90
+++ b/src/submodules/FEVariable/src/FEVariable_SubtractionMethod@Methods.F90
@@ -14,10 +14,26 @@
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
!
+
+SUBMODULE(FEVariable_SubtractionMethod) Methods
+
+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
+
+USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+
#define _OP_ -
-SUBMODULE(FEVariable_Method) SubtractionMethods
-USE BaseMethod
IMPLICIT NONE
CONTAINS
@@ -26,62 +42,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 +97,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,36 +119,26 @@
!----------------------------------------------------------------------------
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
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-END SUBMODULE SubtractionMethods
+END SUBMODULE Methods
#undef _OP_
diff --git a/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90
new file mode 100644
index 000000000..5697bd0fc
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_UnaryMethod@Methods.F90
@@ -0,0 +1,230 @@
+! 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(FEVariable_UnaryMethod) Methods
+USE ApproxUtility, ONLY: OPERATOR(.APPROXEQ.)
+USE GlobalData, ONLY: Constant, Space, Time, SpaceTime, &
+ Scalar, Vector, Matrix, &
+ Nodal, Quadrature
+
+USE BaseType, ONLY: TypeFEVariableScalar, &
+ TypeFEVariableVector, &
+ TypeFEVariableMatrix, &
+ TypeFEVariableConstant, &
+ TypeFEVariableSpace, &
+ TypeFEVariableTime, &
+ TypeFEVariableSpaceTime
+
+USE FEVariable_Method, ONLY: NodalVariable, QuadratureVariable, Get
+USE IntegerUtility, ONLY: Get1DIndexFortran
+USE ReallocateUtility, ONLY: Reallocate
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Abs
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Abs
+SELECT CASE (obj%rank)
+
+#define _ELEM_METHOD_ ABS
+CASE (scalar)
+#include "./include/ScalarElemMethod.F90"
+
+CASE (vector)
+#include "./include/VectorElemMethod.F90"
+
+CASE (matrix)
+#include "./include/MatrixElemMethod.F90"
+
+END SELECT
+#undef _ELEM_METHOD_
+
+END PROCEDURE fevar_Abs
+
+!----------------------------------------------------------------------------
+! Power
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Power
+SELECT CASE (obj%rank)
+CASE (scalar)
+#include "./include/ScalarPower.F90"
+CASE (vector)
+#include "./include/VectorPower.F90"
+CASE (matrix)
+#include "./include/MatrixPower.F90"
+END SELECT
+END PROCEDURE fevar_Power
+
+!----------------------------------------------------------------------------
+! Sqrt
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_Sqrt
+#define _ELEM_METHOD_ SQRT
+
+SELECT CASE (obj%rank)
+CASE (scalar)
+#include "./include/ScalarElemMethod.F90"
+CASE (vector)
+#include "./include/VectorElemMethod.F90"
+CASE (matrix)
+#include "./include/MatrixElemMethod.F90"
+END SELECT
+
+#define _ELEM_METHOD_ SQRT
+END PROCEDURE fevar_Sqrt
+
+!----------------------------------------------------------------------------
+! IsEqual
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_IsEqual
+!! Internal variable
+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
+
+!----------------------------------------------------------------------------
+! NotEqual
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_NotEqual
+ans = .FALSE.
+IF (.NOT. ALL(obj1%val.APPROXEQ.obj2%val)) THEN
+ ans = .TRUE.
+ RETURN
+END IF
+
+IF (obj1%defineon .NE. obj2%defineon) THEN
+ ans = .TRUE.
+ RETURN
+END IF
+
+IF (obj1%rank .NE. obj2%rank) THEN
+ ans = .TRUE.
+ RETURN
+END IF
+
+IF (obj1%varType .NE. obj2%varType) THEN
+ ans = .TRUE.
+ RETURN
+END IF
+
+IF (ANY(obj1%s .NE. obj2%s)) THEN
+ ans = .TRUE.
+ RETURN
+END IF
+END PROCEDURE fevar_NotEqual
+
+!----------------------------------------------------------------------------
+! NORM2
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE fevar_norm2
+REAL(DFP), ALLOCATABLE :: r1(:), r2(:, :), m2(:, :), r3(:, :, :), m3(:, :, :)
+
+INTEGER(I4B) :: jj, kk
+
+SELECT CASE (obj%vartype)
+
+CASE (constant)
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(NORM2(obj%val(1:obj%len)), &
+ typeFEVariableScalar, typeFEVariableConstant)
+ ELSE
+ 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))
+ END DO
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r1, &
+ typeFEVariableScalar, typeFEVariableSpace)
+ ELSE
+ 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))
+ END DO
+
+ IF (obj%defineon .EQ. nodal) THEN
+ ans = NodalVariable(r1, &
+ typeFEVariableScalar, typeFEVariableTime)
+ ELSE
+ ans = QuadratureVariable(r1, &
+ typeFEVariableScalar, typeFEVariableTime)
+ END IF
+
+CASE (spacetime)
+
+ r3 = GET(obj, TypeFEVariableVector, TypeFEVariableSpaceTime)
+
+ 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)
+ ELSE
+ ans = QuadratureVariable(r2, &
+ typeFEVariableScalar, typeFEVariableSpaceTime)
+ END IF
+
+END SELECT
+END PROCEDURE fevar_norm2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
+
diff --git a/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90 b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90
new file mode 100644
index 000000000..e2dfa8d19
--- /dev/null
+++ b/src/submodules/FEVariable/src/FEVariable_VectorInterpolationMethod@Methods.F90
@@ -0,0 +1,543 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(FEVariable_VectorInterpolationMethod) Methods
+USE BaseType, ONLY: TypeFEVariableConstant, TypeFEVariableSpace, &
+ TypeFEVariableTime, TypeFEVariableSpaceTime
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromNodal1_(ans, scale, N, nns, nsd, &
+ nips, val, valStart, valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, nsd, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: ips, jj, istart, iend
+
+ DO ips = 1, nips
+ DO jj = 1, nns
+ istart = (jj - 1) * nsd + 1 + valStart
+ iend = jj * nsd + valStart
+ ans(1:nsd, ips) = ans(1:nsd, ips) &
+ + scale * N(jj, ips) * val(istart:iend)
+ END DO
+ END DO
+
+ valEnd = valStart + nns * nsd
+
+END SUBROUTINE MasterGetInterpolationFromNodal1_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromNodal2_(ans, scale, N, nns, nsd, &
+ nips, val, valStart, valEnd, &
+ ansStart, ansEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, nsd, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+ INTEGER(I4B), INTENT(IN) :: ansStart
+ INTEGER(I4B), INTENT(OUT) :: ansEnd
+
+ INTEGER(I4B) :: ips, jj, ival, jval, ians, jans
+
+ DO ips = 1, nips
+ ians = (ips - 1) * nsd + 1 + ansStart
+ jans = ips * nsd + ansStart
+
+ DO jj = 1, nns
+ ival = (jj - 1) * nsd + 1 + valStart
+ jval = jj * nsd + valStart
+ ans(ians:jans) = ans(ians:jans) &
+ + scale * N(jj, ips) * val(ival:jval)
+ END DO
+ END DO
+
+ valEnd = valStart + nns * nsd
+ ansEnd = ansStart + nips * nsd
+
+END SUBROUTINE MasterGetInterpolationFromNodal2_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromNodal3_(ans, scale, N, nns, nsd, &
+ spaceIndx, val, valStart, &
+ valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ REAL(DFP), INTENT(IN) :: N(:, :)
+ INTEGER(I4B), INTENT(IN) :: nns, nsd, spaceIndx
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: jj, istart, iend
+
+ DO jj = 1, nns
+ istart = (jj - 1) * nsd + 1 + valStart
+ iend = jj * nsd + valStart
+ ans(1:nsd) = ans(1:nsd) &
+ + scale * N(jj, spaceIndx) * val(istart:iend)
+ END DO
+
+ valEnd = valStart + nns * nsd
+
+END SUBROUTINE MasterGetInterpolationFromNodal3_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromQuadrature1_(ans, scale, nsd, &
+ nips, val, valStart, &
+ valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(IN) :: nsd, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: ips, istart, iend
+
+ DO ips = 1, nips
+ istart = (ips - 1) * nsd + 1 + valStart
+ iend = ips * nsd + valStart
+ ans(1:nsd, ips) = ans(1:nsd, ips) + scale * val(istart:iend)
+ END DO
+
+ valEnd = valStart + nips * nsd
+
+END SUBROUTINE MasterGetInterpolationFromQuadrature1_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromQuadrature2_(ans, scale, nsd, &
+ nips, val, valStart, &
+ valEnd, ansStart, &
+ ansEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(IN) :: nsd, nips
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+ INTEGER(I4B), INTENT(IN) :: ansStart
+ INTEGER(I4B), INTENT(OUT) :: ansEnd
+
+ INTEGER(I4B) :: ii, tsize
+
+ tsize = nips * nsd
+ valEnd = valStart + tsize
+ ansEnd = ansStart + tsize
+
+ DO ii = 1, tsize
+ ans(ansStart + ii) = ans(ansStart + ii) + scale * val(valStart + ii)
+ END DO
+END SUBROUTINE MasterGetInterpolationFromQuadrature2_
+
+!----------------------------------------------------------------------------
+! MasterGetInterpolation_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE MasterGetInterpolationFromQuadrature3_(ans, scale, nsd, &
+ spaceIndx, val, &
+ valStart, valEnd)
+ REAL(DFP), INTENT(INOUT) :: ans(:)
+ REAL(DFP), INTENT(IN) :: scale
+ INTEGER(I4B), INTENT(IN) :: nsd, spaceIndx
+ REAL(DFP), INTENT(IN) :: val(:)
+ INTEGER(I4B), INTENT(IN) :: valStart
+ INTEGER(I4B), INTENT(OUT) :: valEnd
+
+ INTEGER(I4B) :: istart, iend
+
+ istart = (spaceIndx - 1) * nsd + 1 + valStart
+ iend = spaceIndx * nsd + valStart
+ ans(1:nsd) = ans(1:nsd) + scale * val(istart:iend)
+
+ valEnd = valStart + nsd
+END SUBROUTINE MasterGetInterpolationFromQuadrature3_
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VectorConstantGetInterpolation_1
+INTEGER(I4B) :: ii
+
+nrow = obj%s(1)
+ncol = nips
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+DO ii = 1, ncol
+ ans(1:nrow, ii) = ans(1:nrow, ii) + scale * obj%val(1:nrow)
+END DO
+END PROCEDURE VectorConstantGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VectorConstantGetInterpolation_2
+INTEGER(I4B) :: ii, ansStart, valStart, tsize
+
+tsize = ans%s(1) * ans%s(2)
+ansStart = (timeIndx - 1) * tsize
+IF (.NOT. addContribution) ans%val(ansStart + 1:ansStart + tsize) = 0.0_DFP
+
+valStart = 0
+
+DO ii = 1, tsize
+ ans%val(ansStart + ii) = ans%val(ansStart + ii) &
+ + scale * obj%val(valStart + ii)
+END DO
+END PROCEDURE VectorConstantGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VectorConstantGetInterpolation_3
+tsize = obj%s(1)
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+ans(1:tsize) = ans(1:tsize) + scale * obj%val(1:tsize)
+END PROCEDURE VectorConstantGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VectorSpaceGetInterpolation_1
+INTEGER(I4B) :: valEnd
+
+nrow = obj%s(1)
+ncol = nips
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ !! Nodal Vector Space
+ !! Convert nodal values to quadrature values by using N(:,:)
+ !! make sure nns .LE. obj%len
+
+ CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=scale, N=N, nns=nns, &
+ nsd=nrow, nips=nips, val=obj%val, &
+ valStart=0, valEnd=valEnd)
+
+CASE (TypeFEVariableOpt%quadrature)
+ !! No need for interpolation, just returnt the quadrature values
+ !! make sure nips .LE. obj%len
+
+ CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, &
+ nsd=nrow, nips=nips, &
+ val=obj%val, valStart=0, &
+ valEnd=valEnd)
+
+END SELECT
+
+END PROCEDURE VectorSpaceGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! Following points should be noted
+! obj%s(1) and ans%s(1) should be same
+! ans%s(2) and nips should be same
+! when obj var type is quadrature, then nips should be same as obj%s(2)
+MODULE PROCEDURE VectorSpaceGetInterpolation_2
+INTEGER(I4B) :: ansStart, valStart, valEnd, ansEnd, nsd
+
+nsd = obj%s(1)
+ansStart = (timeIndx - 1) * ans%s(1) * ans%s(2)
+ansEnd = ansStart + ans%s(1) * ans%s(2)
+valStart = 0
+
+IF (.NOT. addContribution) ans%val(1 + ansStart:ansEnd) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=scale, N=N, &
+ nns=nns, nsd=nsd, nips=nips, &
+ val=obj%val, &
+ valStart=valStart, valEnd=valEnd, &
+ ansStart=ansStart, ansEnd=ansEnd)
+
+CASE (TypeFEVariableOpt%quadrature)
+ CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, &
+ nsd=nsd, nips=nips, &
+ val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd, &
+ ansStart=ansStart, &
+ ansEnd=ansEnd)
+
+END SELECT
+END PROCEDURE VectorSpaceGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! obj%defineon is nodal
+!
+! Nodal Vector Space
+! Convert nodal values to quadrature values by using N(:,:)
+! make sure nns .LE. obj%len
+!
+! obj%defineon is quadrature
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+MODULE PROCEDURE VectorSpaceGetInterpolation_3
+INTEGER(I4B) :: valEnd
+
+tsize = obj%s(1)
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=scale, N=N, nns=nns, &
+ nsd=tsize, spaceIndx=spaceIndx, &
+ val=obj%val, valStart=0, &
+ valEnd=valEnd)
+
+CASE (TypeFEVariableOpt%quadrature)
+ CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, &
+ nsd=tsize, &
+ spaceIndx=spaceIndx, &
+ val=obj%val, valStart=0, &
+ valEnd=valEnd)
+
+END SELECT
+
+END PROCEDURE VectorSpaceGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VectorSpaceTimeGetInterpolation_1
+INTEGER(I4B) :: aa, valStart, valEnd
+REAL(DFP) :: myscale
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+
+nrow = obj%s(1)
+ncol = nips
+IF (.NOT. addContribution) ans(1:nrow, 1:ncol) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+ !! Convert nodal values to quadrature values by using N
+ !! make sure nns .LE. obj%len
+ !! obj%s(1) denotes the nsd in ans
+ !! obj%s(2) should be atleast nns
+ !! obj%s(3) should be atleast nnt
+
+ valEnd = 0
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = valEnd
+ CALL MasterGetInterpolationFromNodal1_(ans=ans, scale=myscale, N=N, &
+ nns=nns, nsd=nrow, nips=nips, &
+ val=obj%val, valStart=valStart, &
+ valEnd=valEnd)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+ !! No need for interpolation, just returnt the quadrature values
+ !! make sure nips .LE. obj%len
+
+ valStart = nips * nrow * (timeIndx - 1)
+ CALL MasterGetInterpolationFromQuadrature1_(ans=ans, scale=scale, &
+ nsd=nrow, nips=nips, &
+ val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd)
+
+END SELECT
+
+END PROCEDURE VectorSpaceTimeGetInterpolation_1
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! Convert nodal values to quadrature values by using N
+! make sure nns .LE. obj%len
+! obj%s(1) denotes the nsd in ans
+! obj%s(2) should be atleast nns
+! obj%s(3) should be atleast nnt
+!
+! No need for interpolation, just returnt the quadrature values
+! make sure nips .LE. obj%len
+MODULE PROCEDURE VectorSpaceTimeGetInterpolation_2
+INTEGER(I4B) :: ansStart, ansEnd, valStart, valEnd, nsd, aa
+REAL(DFP) :: myscale
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+
+nsd = obj%s(1)
+ansStart = (timeIndx - 1) * ans%s(1) * ans%s(2)
+ansEnd = ansStart + ans%s(1) * ans%s(2)
+valStart = 0
+
+SELECT CASE (obj%defineon)
+
+CASE (TypeFEVariableOpt%nodal)
+ valEnd = 0
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = valEnd
+ CALL MasterGetInterpolationFromNodal2_(ans=ans%val, scale=myscale, N=N, &
+ nns=nns, nsd=nsd, nips=nips, &
+ val=obj%val, valStart=valStart, &
+ valEnd=valEnd, ansStart=ansStart, &
+ ansEnd=ansEnd)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+ valStart = nips * nsd * (timeIndx - 1)
+ ansStart = nips * nsd * (timeIndx - 1)
+ CALL MasterGetInterpolationFromQuadrature2_(ans=ans%val, scale=scale, &
+ nsd=nsd, nips=nips, &
+ val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd, &
+ ansStart=ansStart, &
+ ansEnd=ansEnd)
+
+END SELECT
+
+END PROCEDURE VectorSpaceTimeGetInterpolation_2
+
+!----------------------------------------------------------------------------
+! GetInterpolation_
+!----------------------------------------------------------------------------
+
+! obj%defineon is nodal
+!
+! Convert nodal values to quadrature values by using N
+!
+! make sure nns .LE. obj%len
+! obj%s(1) denotes the nsd in ans
+! obj%s(2) should be atleast nns
+! obj%s(3) should be atleast nnt
+!
+! obj%defineon is quadrature
+!
+! No need for interpolation, just return the quadrature values
+! make sure nips .LE. obj%len
+MODULE PROCEDURE VectorSpaceTimeGetInterpolation_3
+INTEGER(I4B) :: aa, valStart, valEnd
+REAL(DFP) :: myscale
+LOGICAL(LGT), PARAMETER :: yes = .TRUE.
+
+tsize = obj%s(1)
+IF (.NOT. addContribution) ans(1:tsize) = 0.0_DFP
+
+SELECT CASE (obj%defineon)
+CASE (TypeFEVariableOpt%nodal)
+
+ valEnd = 0
+ DO aa = 1, nnt
+ myscale = scale * T(aa)
+ valStart = valEnd
+ CALL MasterGetInterpolationFromNodal3_(ans=ans, scale=myscale, N=N, &
+ nns=nns, nsd=tsize, &
+ spaceIndx=spaceIndx, &
+ val=obj%val, valStart=valStart, &
+ valEnd=valEnd)
+ END DO
+
+CASE (TypeFEVariableOpt%quadrature)
+
+ valStart = obj%s(2) * tsize * (timeIndx - 1)
+ CALL MasterGetInterpolationFromQuadrature3_(ans=ans, scale=scale, &
+ nsd=tsize, &
+ spaceIndx=spaceIndx, &
+ val=obj%val, &
+ valStart=valStart, &
+ valEnd=valEnd)
+
+END SELECT
+
+END PROCEDURE VectorSpaceTimeGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! VectorGetInterpolation_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VectorGetInterpolation_3
+INTEGER(I4B) :: vartype
+
+vartype = obj%varType
+
+SELECT CASE (vartype)
+CASE (TypeFEVariableOpt%constant)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableConstant, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, ans=ans, &
+ tsize=tsize, addContribution=addContribution)
+
+CASE (TypeFEVariableOpt%space)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableSpace, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, ans=ans, &
+ tsize=tsize, addContribution=addContribution)
+
+CASE (TypeFEVariableOpt%time)
+ ! CALL GetInterpolation_( &
+ ! obj=obj, rank=rank, vartype=TypeFEVariableTime, N=N, nns=nns, &
+ ! spaceIndx=spaceIndx, timeIndx=timeIndx, scale=scale, ans=ans, &
+ ! tsize=tsize, addContribution=addContribution)
+
+CASE (TypeFEVariableOpt%spacetime)
+ CALL GetInterpolation_( &
+ obj=obj, rank=rank, vartype=TypeFEVariableSpaceTime, N=N, nns=nns, &
+ spaceIndx=spaceIndx, timeIndx=timeIndx, T=T, nnt=nnt, scale=scale, &
+ ans=ans, tsize=tsize, addContribution=addContribution)
+
+END SELECT
+END PROCEDURE VectorGetInterpolation_3
+
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE Methods
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..7e8491cc5
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_constant.F90
@@ -0,0 +1,21 @@
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..c3d68affd
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_constant2.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..d17e017ff
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space.F90
@@ -0,0 +1,22 @@
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..e3a3720ad
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space2.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..271a623c6
--- /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 = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..d56b5d2b9
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_space_time2.F90
@@ -0,0 +1,11 @@
+obj%len = SIZE(val)
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..3ed2f7abe
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_time.F90
@@ -0,0 +1,23 @@
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..802a8533d
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/matrix_time2.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..196477a21
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_constant.F90
@@ -0,0 +1,10 @@
+obj%len = 1
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1) = val
+obj%s(1) = 1
+obj%defineOn = _DEFINEON_
+obj%rank = Scalar
+obj%varType = Constant
+obj%isInit = .TRUE.
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..1a61a03f9
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_space.F90
@@ -0,0 +1,9 @@
+obj%len = SIZE(val)
+obj%s(1) = obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1:obj%len) = val
+obj%defineOn = _DEFINEON_
+obj%rank = SCALAR
+obj%varType = Space
+obj%isInit = .TRUE.
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..1f52da872
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_space_time.F90
@@ -0,0 +1,20 @@
+INTEGER(I4B) :: ii, jj, kk
+
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..5b654bea4
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_space_time2.F90
@@ -0,0 +1,15 @@
+INTEGER(I4B) :: ii
+
+obj%len = SIZE(val)
+!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
+
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..293b2879a
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/scalar_time.F90
@@ -0,0 +1,9 @@
+obj%len = SIZE(val)
+obj%s(1) = obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * obj%len
+ALLOCATE (obj%val(obj%capacity))
+obj%val(1:obj%len) = val
+obj%defineOn = _DEFINEON_
+obj%rank = SCALAR
+obj%varType = Time
+obj%isInit = .TRUE.
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..47e1ca5f0
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_constant.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..173945c30
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space.F90
@@ -0,0 +1,20 @@
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%len = SIZE(val)
+!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..44cb5b65d
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space2.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..20db18d8c
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space_time.F90
@@ -0,0 +1,22 @@
+INTEGER(I4B) :: ii, jj, kk, cnt
+
+obj%len = SIZE(val)
+!obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..448ee6c8d
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_space_time2.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..fa00f6144
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_time.F90
@@ -0,0 +1,20 @@
+INTEGER(I4B) :: ii, jj, cnt
+
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
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..580deb7a7
--- /dev/null
+++ b/src/submodules/FEVariable/src/include/vector_time2.F90
@@ -0,0 +1,12 @@
+obj%len = SIZE(val)
+! obj%capacity = CAPACITY_EXPAND_FACTOR * obj%len
+obj%capacity = TypeFEVariableOpt%capacityExpandFactor * 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
+obj%isInit = .TRUE.
diff --git a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90 b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix11Methods.F90
index b9cf81703..3c6252ec0 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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
!!
- CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar)
+CALL GetInterpolation(obj=masterElemSD, ans=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,50 @@
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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
+CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
+CALL GetInterpolation(obj=slaveElemSD, ans=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 +233,54 @@
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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
+CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
+CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, val=muSlave)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauBar, &
- & val=tauvar )
+CALL GetInterpolation(obj=masterElemSD, ans=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 +288,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..7ea38ee45 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, &
+ & ans=C1, &
+ & c=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, &
+ & ans=C1, &
+ & c=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, &
+ & ans=C1, &
+ & c=elemsd%normal)
+CALL GetInterpolation(obj=elemsd, ans=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, ans=C1, c=elemsd%normal)
+CALL getInterpolation(obj=elemsd, ans=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, ans=C1, c=elemsd%normal)
+CALL getInterpolation(obj=elemsd, ans=muBar, val=mu)
+CALL getInterpolation(obj=elemsd, ans=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..79953118f 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix13Methods.F90
@@ -26,46 +26,46 @@
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
+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, &
+ & ans=masterC1, &
+ & c=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 )
+CALL Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1 )
+DEALLOCATE (m4, realval, masterC1)
!!
END PROCEDURE FacetMatrix13_1
@@ -75,46 +75,46 @@
MODULE PROCEDURE FacetMatrix13_2
!!
- 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
+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, &
+ & ans=masterC1, &
+ & c=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
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
@@ -124,100 +124,99 @@
MODULE PROCEDURE FacetMatrix13_3
!!
- 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
+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, &
+& ans=masterC1, &
+& c=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, ans=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, taubar )
+DEALLOCATE (m4, realval, masterC1, taubar)
!!
END PROCEDURE FacetMatrix13_3
-
!----------------------------------------------------------------------------
! FacetMatrix13
!----------------------------------------------------------------------------
MODULE PROCEDURE FacetMatrix13_4
!!
- 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(:, :, :, :), 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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, ans=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 Convert(from=m4, to=ans)
!!
- DEALLOCATE( m4, realval, masterC1, mubar )
+DEALLOCATE (m4, realval, masterC1, mubar)
!!
END PROCEDURE FacetMatrix13_4
@@ -227,50 +226,50 @@
MODULE PROCEDURE FacetMatrix13_5
!!
- 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
+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, &
+& ans=masterC1, &
+& c=elemsd%normal)
+ !!
+CALL getInterpolation(obj=elemsd, ans=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, ans=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..e83caaab5 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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=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, &
+& ans=masterC1, &
+& c=elemsd%normal)
+ !!
+ !!
+CALL GetInterpolation(obj=elemsd, ans=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
+ !!
+CALL GetInterpolation(obj=elemsd, ans=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
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+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
!!
- realval = elemsd%js * elemsd%ws * elemsd%thickness * mubar * taubar
+CALL Reallocate(m4, nns2, nns1, nsd1, nsd2)
!!
- DO ips = 1, nips
+CALL getProjectionOfdNdXt( &
+& obj=elemsd, &
+& ans=masterC1, &
+& c=elemsd%normal)
+ !!
+CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu)
+CALL GetInterpolation(obj=elemsd, ans=taubar, val=tauvar)
+ !!
+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..4a69f9768 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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- realval = masterElemSD%js * masterElemSD%ws * masterElemSD%thickness
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=muMasterBar, &
- & val=muMaster )
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & ans=muMasterBar, &
+ & val=muMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=muSlaveBar, &
- & val=muSlave )
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & ans=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & ans=tauMasterBar, &
+ & val=tauMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & ans=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & ans=muMasterBar, &
+ & val=muMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & ans=muSlaveBar, &
+ & val=muSlave)
+ !!
+CALL getInterpolation( &
+ & obj=masterElemSD, &
+ & ans=tauMasterBar, &
+ & val=tauMaster)
+ !!
+CALL getInterpolation( &
+ & obj=slaveElemSD, &
+ & ans=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..3636a0eec 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, &
+ & ans=masterC1, &
+ & c=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL GetProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL GetProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & ans=slaveC1, &
+ & c=slaveElemSD%normal)
!!
- CALL getInterpolation(obj=masterElemSD, Interpol=taubar, val=tauvar)
+CALL GetInterpolation(obj=masterElemSD, ans=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, &
+ & ans=masterC1, &
+ & c=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & ans=slaveC1, &
+ & c=slaveElemSD%normal)
!!
- CALL getInterpolation( obj=masterElemSD, interpol=muMasterBar, &
- & val=muMaster )
- CALL getInterpolation( obj=slaveElemSD, interpol=muSlaveBar, &
- & val=muSlave )
+CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, &
+ val=muMaster)
+CALL GetInterpolation(obj=slaveElemSD, ans=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, &
+ & ans=masterC1, &
+ & c=masterElemSD%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemSD, &
- & cdNdXt=slaveC1, &
- & val=slaveElemSD%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemSD, &
+ & ans=slaveC1, &
+ & c=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, ans=muMasterBar, &
+ val=muMaster)
+CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, &
+ val=muSlave)
+CALL GetInterpolation(obj=masterElemSD, ans=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..b0a7cc320 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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, ans=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..e509dccb4 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, ans=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..6ccf5d388 100644
--- a/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90
+++ b/src/submodules/FacetMatrix/src/FacetMatrix_Method@FacetMatrix2Methods.F90
@@ -26,47 +26,44 @@
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, ans=masterC1, c=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 +73,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, ans=masterC1, &
+ c=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 +121,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, ans=masterC1, &
+ c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL GetInterpolation(obj=elemsd, ans=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 +171,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, ans=masterC1, c=elemsd%normal)
+CALL GetInterpolation(obj=elemsd, ans=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 +219,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, ans=masterC1, c=elemsd%normal)
+CALL GetInterpolation(obj=elemsd, ans=muBar, val=mu)
+CALL GetInterpolation(obj=elemsd, ans=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 +267,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..32deda6dc 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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL GetInterpolation(obj=elemsd, ans=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL GetInterpolation(obj=elemsd, ans=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL GetInterpolation(obj=elemsd, ans=mubar, val=mu)
+CALL GetInterpolation(obj=elemsd, ans=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..2a3877858 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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, ans=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, ans=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, &
+ & ans=masterC1, &
+ & c=elemsd%normal)
!!
- CALL getInterpolation(obj=elemsd, Interpol=mubar, val=mu)
- CALL getInterpolation(obj=elemsd, Interpol=taubar, val=tauvar)
+CALL getInterpolation(obj=elemsd, ans=mubar, val=mu)
+CALL getInterpolation(obj=elemsd, ans=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..1e66637a7 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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=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,93 @@
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
+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)
!!
- DO ips = 1, nips
+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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
+ !!
+CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster)
+ !!
+CALL getInterpolation(obj=slaveElemSD, ans=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))
+ 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, &
- & muMasterBar, muSlaveBar, G12 )
+DEALLOCATE (realval, masterC1, slaveC1, C2, m4, i3, &
+ & muMasterBar, muSlaveBar, G12)
!!
END PROCEDURE FacetMatrix5_4
@@ -388,99 +382,93 @@
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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
!!
- CALL getProjectionOfdNdXt( &
- & obj=slaveElemsd, &
- & cdNdXt=slaveC1, &
- & val=slaveElemsd%normal )
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
!!
- CALL getInterpolation( &
- & obj=masterElemSD, &
- & interpol=tauMasterBar, &
- & val=tauMaster )
+CALL GetInterpolation(obj=masterElemSD, ans=tauMasterBar, val=tauMaster)
!!
- CALL getInterpolation( &
- & obj=slaveElemSD, &
- & interpol=tauSlaveBar, &
- & val=tauSlave )
+CALL GetInterpolation(obj=slaveElemSD, ans=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 +478,101 @@
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, &
+ & ans=masterC1, &
+ & c=masterElemsd%normal)
+ !!
+CALL getProjectionOfdNdXt( &
+ & obj=slaveElemsd, &
+ & ans=slaveC1, &
+ & c=slaveElemsd%normal)
+ !!
+CALL GetInterpolation(obj=masterElemSD, ans=muMasterBar, val=muMaster)
+ !!
+CALL GetInterpolation(obj=slaveElemSD, ans=muSlaveBar, val=muSlave)
+ !!
+CALL GetInterpolation(obj=masterElemSD, ans=tauMasterBar, val=tauMaster)
+ !!
+CALL GetInterpolation(obj=slaveElemSD, ans=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/ForceVector/src/ForceVector_Method@Methods.F90 b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90
index c090b621c..a55659e63 100644
--- a/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90
+++ b/src/submodules/ForceVector/src/ForceVector_Method@Methods.F90
@@ -1,5 +1,6 @@
! This program is a part of EASIFEM library
-! Copyright (C) 2020-2021 Vikas Sharma, Ph.D
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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
@@ -13,10 +14,19 @@
!
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
-!
SUBMODULE(ForceVector_Method) Methods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
+USE ProductUtility, ONLY: OuterProd_
+USE ProductUtility, ONLY: OTimesTilda_
+USE FEVariable_Method, ONLY: FEVariableSize => Size
+USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_
+USE BaseType, ONLY: math => TypeMathOpt
+
+#ifdef DEBUG_VER
+USE Display_Method, ONLY: Display
+#endif
+
IMPLICIT NONE
CONTAINS
@@ -24,177 +34,527 @@
! ForceVector
!----------------------------------------------------------------------------
+MODULE PROCEDURE ForceVector1
+INTEGER(I4B) :: tsize
+CALL Reallocate(ans, test%nns)
+CALL ForceVector_(test=test, ans=ans, tsize=tsize)
+END PROCEDURE ForceVector1
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE ForceVector_1
! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP) :: realval
INTEGER(I4B) :: ips
-! main
-realval = test%js * test%ws * test%thickness
-CALL Reallocate(ans, SIZE(test%N, 1))
+tsize = test%nns
+ans(1:tsize) = 0.0_DFP
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test%N(:, ips)
+DO ips = 1, test%nips
+ realval = test%js(ips) * test%ws(ips) * test%thickness(ips)
+ ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips)
END DO
-DEALLOCATE (realval)
END PROCEDURE ForceVector_1
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
+MODULE PROCEDURE ForceVector2
+INTEGER(I4B) :: tsize
+tsize = test%nns
+CALL Reallocate(ans, tsize)
+CALL ForceVector_(test=test, c=c, crank=crank, ans=ans, tsize=tsize)
+END PROCEDURE ForceVector2
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE ForceVector_2
-! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
+REAL(DFP) :: realval, T(0), cbar
INTEGER(I4B) :: ips
-! main
-CALL GetInterpolation(obj=test, interpol=realval, val=c)
-realval = test%js * test%ws * test%thickness * realval
-CALL Reallocate(ans, SIZE(test%N, 1))
+tsize = test%nns
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test%N(:, ips)
+ans(1:tsize) = math%zero
+
+DO ips = 1, test%nips
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=cbar)
+
+ realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * cbar
+
+ ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips)
END DO
-DEALLOCATE (realval)
END PROCEDURE ForceVector_2
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE ForceVector_2b
+MODULE PROCEDURE ForceVector3
+INTEGER(I4B) :: nrow, ncol
+
+nrow = FEVariableSize(c, 1)
+ncol = test%nns
+CALL Reallocate(ans, nrow, ncol)
+CALL ForceVector_(test=test, c=c, crank=crank, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE ForceVector3
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_3
! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-INTEGER(I4B) :: ips
+REAL(DFP) :: realval, cbar(3), T(0)
+INTEGER(I4B) :: ips, i1, i2
+
+nrow = FEVariableSize(c, 1)
+ncol = test%nns
+ans(1:nrow, 1:ncol) = 0.0_DFP
-realval = test%js * test%ws * test%thickness * c
-CALL Reallocate(ans, SIZE(test%N, 1))
+DO ips = 1, test%nips
+ realval = test%js(ips) * test%ws(ips) * test%thickness(ips)
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test%N(:, ips)
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=cbar, tsize=i1)
+
+ CALL OuterProd_(a=cbar(1:nrow), b=test%N(1:ncol, ips), &
+ anscoeff=math%one, scale=realval, &
+ ans=ans, nrow=i1, ncol=i2)
END DO
+END PROCEDURE ForceVector_3
+
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector4
+INTEGER(I4B) :: dim1, dim2, dim3
+dim1 = FEVariableSize(c, 1)
+dim2 = FEVariableSize(c, 2)
+dim3 = test%nns
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL ForceVector_(test=test, c=c, crank=crank, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3)
+END PROCEDURE ForceVector4
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
-DEALLOCATE (realval)
+MODULE PROCEDURE ForceVector_4
+REAL(DFP) :: cbar(3, 3), realval, T(0)
+INTEGER(I4B) :: ips, i1, i2, i3
+
+dim1 = FEVariableSize(c, 1)
+dim2 = FEVariableSize(c, 2)
+dim3 = test%nns
+
+ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
-END PROCEDURE ForceVector_2b
+DO ips = 1, test%nips
+ realval = test%js(ips) * test%ws(ips) * test%thickness(ips)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=cbar, nrow=i1, ncol=i2)
+
+ CALL OuterProd_(a=cbar(1:dim1, 1:dim2), b=test%N(1:dim3, ips), &
+ anscoeff=math%one, scale=realval, &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3)
+END DO
+END PROCEDURE ForceVector_4
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE ForceVector_3
-! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: cbar(:, :)
+MODULE PROCEDURE ForceVector5
+INTEGER(I4B) :: tsize
+tsize = test%nns
+CALL Reallocate(ans, tsize)
+CALL ForceVector_(test=test, c1=c1, c2=c2, c1rank=c1rank, c2rank=c2rank, &
+ ans=ans, tsize=tsize)
+END PROCEDURE ForceVector5
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_5
+REAL(DFP) :: c1bar, c2bar, realval, T(0)
INTEGER(I4B) :: ips
-! main
-CALL GetInterpolation(obj=test, interpol=cbar, val=c)
-realval = test%js * test%ws * test%thickness
-CALL Reallocate(ans, SIZE(cbar, 1), SIZE(test%N, 1))
+tsize = test%nns
+ans(1:tsize) = 0.0_DFP
+
+DO ips = 1, test%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=c2bar)
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD(cbar(:, ips), test%N(:, ips))
+ realval = test%js(ips) * test%ws(ips) * test%thickness(ips) &
+ * c1bar * c2bar
+
+ ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips)
END DO
+END PROCEDURE ForceVector_5
-DEALLOCATE (realval, cbar)
-END PROCEDURE ForceVector_3
+!----------------------------------------------------------------------------
+! ForceVector
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector6
+INTEGER(I4B) :: nrow, ncol
+nrow = FEVariableSize(c2, 1)
+ncol = test%nns
+CALL Reallocate(ans, nrow, ncol)
+CALL ForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE ForceVector6
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_6
+! Define internal variable
+REAL(DFP) :: realval, c1bar, c2bar(3), T(0)
+INTEGER(I4B) :: ips, i1, i2
+
+nrow = FEVariableSize(c2, 1)
+ncol = test%nns
+ans(1:nrow, 1:ncol) = 0.0_DFP
+
+DO ips = 1, test%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=c2bar, tsize=i1)
+
+ realval = c1bar * test%js(ips) * test%ws(ips) * test%thickness(ips)
+
+ CALL OuterProd_(a=c2bar(1:nrow), b=test%N(1:ncol, ips), &
+ anscoeff=math%one, scale=realval, &
+ ans=ans, nrow=i1, ncol=i2)
+END DO
+END PROCEDURE ForceVector_6
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE ForceVector_4
+MODULE PROCEDURE ForceVector7
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = FEVariableSize(c2, 1)
+dim2 = FEVariableSize(c2, 2)
+dim3 = test%nns
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL ForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3)
+END PROCEDURE ForceVector7
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_7
! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: cbar(:, :, :)
-INTEGER(I4B) :: ips
+REAL(DFP) :: c2bar(3, 3), realval, c1bar, T(0)
+INTEGER(I4B) :: ips, i1, i2, i3
! main
-CALL GetInterpolation(obj=test, interpol=cbar, val=c)
-realval = test%js * test%ws * test%thickness
-CALL Reallocate(ans, SIZE(cbar, 1), SIZE(cbar, 2), SIZE(test%N, 1))
+dim1 = FEVariableSize(c2, 1)
+dim2 = FEVariableSize(c2, 2)
+dim3 = test%nns
+ans(1:dim1, 1:dim2, 1:dim3) = math%zero
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD(cbar(:, :, ips), test%N(:, ips))
-END DO
+DO ips = 1, test%nips
-DEALLOCATE (realval, cbar)
-END PROCEDURE ForceVector_4
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2)
+
+ realval = c1bar * test%js(ips) * test%ws(ips) * test%thickness(ips)
+
+ CALL OuterProd_(a=c2bar(1:dim1, 1:dim2), b=test%N(1:dim3, ips), &
+ anscoeff=math%one, scale=realval, &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3)
+END DO
+END PROCEDURE ForceVector_7
!----------------------------------------------------------------------------
! ForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE ForceVector_5
+MODULE PROCEDURE ForceVector8
+INTEGER(I4B) :: tsize
+tsize = test%nns
+CALL Reallocate(ans, tsize)
+CALL ForceVector_(test=test, c=c, ans=ans, tsize=tsize)
+END PROCEDURE ForceVector8
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_8
! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c1bar(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:)
INTEGER(I4B) :: ips
+REAL(DFP) :: realval
-! main
-CALL GetInterpolation(obj=test, interpol=c1bar, val=c1)
-CALL GetInterpolation(obj=test, interpol=c2bar, val=c2)
-realval = test%js * test%ws * test%thickness * c1bar * c2bar
-CALL Reallocate(ans, SIZE(test%N, 1))
+tsize = test%nns
+ans(1:tsize) = 0.0_DFP
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test%N(:, ips)
+DO ips = 1, test%nips
+ realval = test%js(ips) * test%ws(ips) * test%thickness(ips) * c(ips)
+ ans(1:tsize) = ans(1:tsize) + realval * test%N(1:tsize, ips)
END DO
-
-DEALLOCATE (realval, c1bar, c2bar)
-END PROCEDURE ForceVector_5
+END PROCEDURE ForceVector_8
!----------------------------------------------------------------------------
-! ForceVector
+! ForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE ForceVector_6
+MODULE PROCEDURE ForceVector_9
! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c1bar(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :)
INTEGER(I4B) :: ips
+REAL(DFP) :: realval
-! main
-CALL GetInterpolation(obj=test, interpol=c1bar, val=c1)
-CALL GetInterpolation(obj=test, interpol=c2bar, val=c2)
-realval = test%js * test%ws * test%thickness * c1bar
-CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(test%N, 1))
+tsize = nns
+ans(1:tsize) = 0.0_DFP
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD(c2bar(:, ips), test%N(:, ips))
+DO ips = 1, nips
+ realval = js(ips) * ws(ips) * thickness(ips) * c(ips)
+ ans(1:tsize) = ans(1:tsize) + realval * N(1:tsize, ips)
END DO
+END PROCEDURE ForceVector_9
-DEALLOCATE (realval, c1bar, c2bar)
-END PROCEDURE ForceVector_6
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_10
+LOGICAL(LGT) :: donothing
+INTEGER(I4B) :: a, b, mynns
+
+IF (.NOT. skipVertices) THEN
+ CALL ForceVector_( &
+ N=N, js=js, ws=ws, thickness=thickness, nns=nns, nips=nips, c=c, &
+ ans=ans, tsize=tsize)
+ RETURN
+END IF
+
+donothing = nns .LE. tVertices
+IF (donothing) THEN
+ tsize = 0
+ RETURN
+END IF
+
+a = tVertices + 1
+b = nns
+mynns = nns - tVertices
+
+CALL ForceVector_( &
+ N=N(a:b, :), js=js, ws=ws, thickness=thickness, nns=mynns, nips=nips, c=c, &
+ ans=ans, tsize=tsize)
+END PROCEDURE ForceVector_10
!----------------------------------------------------------------------------
-! ForceVector
+! ForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE ForceVector_7
+MODULE PROCEDURE ForceVector_11
+! Define internal variable
+INTEGER(I4B) :: ips, ipt
+REAL(DFP) :: realval
+
+tsize = nns * nnt
+ans(1:tsize) = 0.0_DFP
+
+DO ipt = 1, nipt
+ DO ips = 1, nips
+ realval = js(ips) * ws(ips) * spaceThickness(ips) * c(ips, ipt) * &
+ wt(ipt) * jt(ipt) * timeThickness(ipt)
+ CALL OTimesTilda_(a=timeN(1:nnt, ipt), b=spaceN(1:nns, ips), &
+ anscoeff=math%one, scale=realval, ans=ans, tsize=tsize)
+ END DO
+END DO
+END PROCEDURE ForceVector_11
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_12
+LOGICAL(LGT) :: donothing
+INTEGER(I4B) :: a, b, d, e, mynns, mynnt
+
+IF (.NOT. skipVertices) THEN
+ CALL ForceVector_( &
+ spaceN=spaceN, timeN=timeN, js=js, ws=ws, jt=jt, wt=wt, &
+ spaceThickness=spaceThickness, timeThickness=timeThickness, nns=nns, &
+ nnt=nnt, nips=nips, nipt=nipt, c=c, ans=ans, tsize=tsize)
+ RETURN
+END IF
+
+donothing = (nns .LE. tSpaceVertices) .OR. (nnt .LE. tTimeVertices)
+IF (donothing) THEN
+ tsize = 0
+ RETURN
+END IF
+
+a = tSpaceVertices + 1
+b = nns
+mynns = nns - tSpaceVertices
+
+d = tTimeVertices + 1
+e = nnt
+mynnt = nnt - tTimeVertices
+
+CALL ForceVector_( &
+ spaceN=spaceN(a:b, :), timeN=timeN(d:e, :), js=js, ws=ws, jt=jt, wt=wt, &
+ spaceThickness=spaceThickness, timeThickness=timeThickness, nns=mynns, &
+ nnt=mynnt, nips=nips, nipt=nipt, c=c, ans=ans, tsize=tsize)
+END PROCEDURE ForceVector_12
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_13
! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c1bar(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :, :)
INTEGER(I4B) :: ips
+REAL(DFP) :: realval
-! main
-CALL GetInterpolation(obj=test, interpol=c1bar, val=c1)
-CALL GetInterpolation(obj=test, interpol=c2bar, val=c2)
-realval = test%js * test%ws * test%thickness * c1bar
-CALL Reallocate(ans, SIZE(c2bar, 1), SIZE(c2bar, 2), SIZE(test%N, 1))
+tsize = nns
+ans(1:tsize) = 0.0_DFP
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD(c2bar(:, :, ips), test%N(:, ips))
+DO ips = 1, nips
+ realval = js(ips) * ws(ips) * thickness(ips)
+ ans(1:tsize) = ans(1:tsize) + realval * N(1:tsize, ips)
END DO
+END PROCEDURE ForceVector_13
-DEALLOCATE (realval, c1bar, c2bar)
-END PROCEDURE ForceVector_7
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_14
+LOGICAL(LGT) :: donothing
+INTEGER(I4B) :: a, b, mynns
+
+IF (.NOT. skipVertices) THEN
+ CALL ForceVector_( &
+ N=N, js=js, ws=ws, thickness=thickness, nns=nns, nips=nips, &
+ ans=ans, tsize=tsize)
+ RETURN
+END IF
+
+donothing = nns .LE. tVertices
+IF (donothing) THEN
+ tsize = 0
+ RETURN
+END IF
+
+a = tVertices + 1
+b = nns
+mynns = nns - tVertices
+
+CALL ForceVector_( &
+ N=N(a:b, :), js=js, ws=ws, thickness=thickness, nns=mynns, nips=nips, &
+ ans=ans, tsize=tsize)
+END PROCEDURE ForceVector_14
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_15
+! Define internal variable
+INTEGER(I4B) :: ips, ipt
+REAL(DFP) :: realval
+
+tsize = nns * nnt
+ans(1:tsize) = 0.0_DFP
+
+DO ipt = 1, nipt
+ DO ips = 1, nips
+ realval = js(ips) * ws(ips) * spaceThickness(ips) * &
+ wt(ipt) * jt(ipt) * timeThickness(ipt)
+ CALL OTimesTilda_(a=timeN(1:nnt, ipt), b=spaceN(1:nns, ips), &
+ anscoeff=math%one, scale=realval, ans=ans, tsize=tsize)
+ END DO
+END DO
+END PROCEDURE ForceVector_15
+
+!----------------------------------------------------------------------------
+! ForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ForceVector_16
+LOGICAL(LGT) :: donothing
+INTEGER(I4B) :: a, b, d, e, mynns, mynnt
+
+IF (.NOT. skipVertices) THEN
+ CALL ForceVector_( &
+ spaceN=spaceN, timeN=timeN, js=js, ws=ws, jt=jt, wt=wt, &
+ spaceThickness=spaceThickness, timeThickness=timeThickness, nns=nns, &
+ nnt=nnt, nips=nips, nipt=nipt, ans=ans, tsize=tsize)
+ RETURN
+END IF
+
+donothing = (nns .LE. tSpaceVertices) .OR. (nnt .LE. tTimeVertices)
+IF (donothing) THEN
+ tsize = 0
+ RETURN
+END IF
+
+a = tSpaceVertices + 1
+b = nns
+mynns = nns - tSpaceVertices
+
+d = tTimeVertices + 1
+e = nnt
+mynnt = nnt - tTimeVertices
+
+CALL ForceVector_( &
+ spaceN=spaceN(a:b, :), timeN=timeN(d:e, :), js=js, ws=ws, jt=jt, wt=wt, &
+ spaceThickness=spaceThickness, timeThickness=timeThickness, nns=mynns, &
+ nnt=mynnt, nips=nips, nipt=nipt, ans=ans, tsize=tsize)
+END PROCEDURE ForceVector_16
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Geometry/CMakeLists.txt b/src/submodules/Geometry/CMakeLists.txt
index 74342d10f..d49cf928f 100644
--- a/src/submodules/Geometry/CMakeLists.txt
+++ b/src/submodules/Geometry/CMakeLists.txt
@@ -26,14 +26,4 @@ target_sources(
${src_path}/ReferenceElement_Method@LocalNodeCoordsMethods.F90
${src_path}/ReferenceElement_Method@EnquireMethods.F90
${src_path}/ReferenceElement_Method@VTKMethods.F90
- ${src_path}/ReferencePoint_Method@Methods.F90
- ${src_path}/ReferenceLine_Method@Methods.F90
- ${src_path}/Line_Method@Methods.F90
- ${src_path}/ReferenceTriangle_Method@Methods.F90
- ${src_path}/Triangle_Method@Methods.F90
- ${src_path}/Plane_Method@Methods.F90
- ${src_path}/ReferenceQuadrangle_Method@Methods.F90
- ${src_path}/ReferenceTetrahedron_Method@Methods.F90
- ${src_path}/ReferenceHexahedron_Method@Methods.F90
- ${src_path}/ReferencePrism_Method@Methods.F90
- ${src_path}/ReferencePyramid_Method@Methods.F90)
+ ${src_path}/Plane_Method@Methods.F90)
diff --git a/src/submodules/Geometry/src/Line_Method@Methods.F90 b/src/submodules/Geometry/src/Line_Method@Methods.F90
deleted file mode 100644
index 93e5046f8..000000000
--- a/src/submodules/Geometry/src/Line_Method@Methods.F90
+++ /dev/null
@@ -1,339 +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(Line_Method) Methods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE line_exp_is_degenerate_nd
-ans = (all(p1(1:dim_num) == p2(1:dim_num)))
-END PROCEDURE line_exp_is_degenerate_nd
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE line_exp2imp_2d
-integer(i4b), parameter :: dim_num = 2
-real(dfp) norm
-!
-! Take care of degenerate cases.
-!
-if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then
- return
-end if
-
-a = p2(2) - p1(2)
-b = p1(1) - p2(1)
-c = p2(1) * p1(2) - p1(1) * p2(2)
-
-norm = a * a + b * b + c * c
-
-if (0.0D+00 < norm) then
- a = a / norm
- b = b / norm
- c = c / norm
-end if
-
-if (a < 0.0D+00) then
- a = -a
- b = -b
- c = -c
-end if
-
-END PROCEDURE line_exp2imp_2d
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure line_imp_is_degenerate_2d
-ans = (a * a + b * b == 0.0D+00)
-end procedure line_imp_is_degenerate_2d
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure lines_imp_int_2d
-integer(kind=4), parameter :: dim_num = 2
-real(kind=8) a(dim_num, dim_num + 1)
-integer(kind=4) info
-!
-p(1:dim_num) = 0.0D+00
-!
-! Refuse to handle degenerate lines.
-!
-if (line_imp_is_degenerate_2d(a1, b1, c1)) then
- ival = -1
- return
-end if
-!
-if (line_imp_is_degenerate_2d(a2, b2, c2)) then
- ival = -2
- return
-end if
-!
-! Set up and solve a linear system.
-!
-a(1, 1) = a1
-a(1, 2) = b1
-a(1, 3) = -c1
-a(2, 1) = a2
-a(2, 2) = b2
-a(2, 3) = -c2
-!
-call r8mat_solve(2, 1, a, info)
-!
-! If the inverse exists, then the lines intersect at the solution point.
-!
-if (info == 0) then
-
- ival = 1
- p(1:dim_num) = a(1:dim_num, 3)
-!
-! If the inverse does not exist, then the lines are parallel
-! or coincident. Check for parallelism by seeing if the
-! C entries are in the same ratio as the A or B entries.
-!
-else
- ival = 0
- if (a1 == 0.0D+00) then
- if (b2 * c1 == c2 * b1) then
- ival = 2
- end if
- else
- if (a2 * c1 == c2 * a1) then
- ival = 2
- end if
- end if
-end if
-!
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure line_exp_perp_2d
-integer(kind=4), parameter :: dim_num = 2
-real(kind=8) bot
-real(kind=8) t
-!
-flag = .false.
-if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then
- flag = .true.
- p4(1:2) = r8_huge()
- return
-end if
-!
-bot = sum((p2(1:dim_num) - p1(1:dim_num))**2)
-!
-! (P3-P1) dot (P2-P1) = Norm(P3-P1) * Norm(P2-P1) * Cos(Theta).
-!
-! (P3-P1) dot (P2-P1) / Norm(P3-P1)^2 = normalized coordinate T
-! of the projection of (P3-P1) onto (P2-P1).
-!
-t = sum((p1(1:dim_num) - p3(1:dim_num)) &
- * (p1(1:dim_num) - p2(1:dim_num))) / bot
-!
-p4(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
-!
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure lines_exp_int_2d
-integer(kind=4), parameter :: dim_num = 2
-real(kind=8) a1
-real(kind=8) a2
-real(kind=8) b1
-real(kind=8) b2
-real(kind=8) c1
-real(kind=8) c2
-logical(kind=4) point_1
-logical(kind=4) point_2
-!
-ival = 0
-p(1:dim_num) = 0.0D+00
-!
-! Check whether either line is a point.
-!
-if (all(p1(1:dim_num) == p2(1:dim_num))) then
- point_1 = .true.
-else
- point_1 = .false.
-end if
-
-if (all(q1(1:dim_num) == q2(1:dim_num))) then
- point_2 = .true.
-else
- point_2 = .false.
-end if
-!
-! Convert the lines to ABC format.
-!
-if (.not. point_1) then
- call line_exp2imp_2d(p1, p2, a1, b1, c1)
-end if
-
-if (.not. point_2) then
- call line_exp2imp_2d(q1, q2, a2, b2, c2)
-end if
-!
-! Search for intersection of the lines.
-!
-if (point_1 .and. point_2) then
- if (all(p1(1:dim_num) == q1(1:dim_num))) then
- ival = 1
- p(1:dim_num) = p1(1:dim_num)
- end if
-else if (point_1) then
- if (a2 * p1(1) + b2 * p1(2) == c2) then
- ival = 1
- p(1:dim_num) = p1(1:dim_num)
- end if
-else if (point_2) then
- if (a1 * q1(1) + b1 * q1(2) == c1) then
- ival = 1
- p(1:dim_num) = q1(1:dim_num)
- end if
-else
- call lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p)
-end if
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure segment_point_dist_2d
-integer(kind=4), parameter :: dim_num = 2
-real(kind=8) bot
-real(kind=8) pn(dim_num)
-real(kind=8) t
-!
-! If the line segment is actually a point, then the answer is easy.
-!
-if (all(p1(1:dim_num) == p2(1:dim_num))) then
- t = 0.0D+00
-else
- bot = sum((p2(1:dim_num) - p1(1:dim_num))**2)
- t = sum((p(1:dim_num) - p1(1:dim_num)) &
- * (p2(1:dim_num) - p1(1:dim_num))) / bot
- t = max(t, 0.0D+00)
- t = min(t, 1.0D+00)
-end if
-!
-pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
-dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2))
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure segment_point_dist_3d
-integer(i4b), parameter :: dim_num = 3
-real(dfp) bot
-real(dfp) pn(dim_num)
-real(dfp) t
-!
-! If the line segment is actually a point, then the answer is easy.
-!
-if (all(p1(1:dim_num) == p2(1:dim_num))) then
- t = 0.0D+00
-else
- bot = sum((p2(1:dim_num) - p1(1:dim_num))**2)
- t = sum((p(1:dim_num) - p1(1:dim_num)) &
- * (p2(1:dim_num) - p1(1:dim_num))) / bot
- t = max(t, 0.0D+00)
- t = min(t, 1.0D+00)
-end if
-
-pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
-dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2))
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure line_exp_point_dist_signed_2d
-integer(kind=4), parameter :: dim_num = 2
-real(kind=8) a
-real(kind=8) b
-real(kind=8) c
-!
-! If the explicit line degenerates to a point, the computation is easy.
-!
-if (line_exp_is_degenerate_nd(dim_num, p1, p2)) then
- dist_signed = sqrt(sum((p1(1:dim_num) - p(1:dim_num))**2))
-!
-! Convert the explicit line to the implicit form A * P(1) + B * P(2) + C = 0.
-! This makes the computation of the signed distance to (X,Y) easy.
-!
-else
- a = p2(2) - p1(2)
- b = p1(1) - p2(1)
- c = p2(1) * p1(2) - p1(1) * p2(2)
- dist_signed = (a * p(1) + b * p(2) + c) / sqrt(a * a + b * b)
-end if
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-module procedure segment_point_near_2d
-integer(kind=4), parameter :: dim_num = 2
-real(kind=8) bot
-!
-! If the line segment is actually a point, then the answer is easy.
-!
-if (all(p1(1:dim_num) == p2(1:dim_num))) then
- t = 0.0D+00
-else
- bot = sum((p2(1:dim_num) - p1(1:dim_num))**2)
- t = sum((p(1:dim_num) - p1(1:dim_num)) &
- * (p2(1:dim_num) - p1(1:dim_num))) / bot
- t = max(t, 0.0D+00)
- t = min(t, 1.0D+00)
-end if
-!
-pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
-dist = sqrt(sum((p(1:dim_num) - pn(1:dim_num))**2))
-end procedure
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-#include "./inc/aux.inc"
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE Methods
diff --git a/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90 b/src/submodules/Geometry/src/ReferenceElement_Method@GeometryMethods.F90
index fac9e0eae..6bed1f443 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
!----------------------------------------------------------------------------
@@ -380,43 +479,85 @@
SELECT CASE (topo)
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
+!----------------------------------------------------------------------------
+! GetFaceElemType
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType2
+INTEGER(I4B) :: topo
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+
+CASE (Line)
+ CALL GetFaceElemType_Line(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+CASE (Triangle)
+ CALL GetFaceElemType_Triangle(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+CASE (Quadrangle)
+ CALL GetFaceElemType_Quadrangle(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+CASE (Tetrahedron)
+ CALL GetFaceElemType_Tetrahedron(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+CASE (Hexahedron)
+ CALL GetFaceElemType_Hexahedron(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+CASE (Prism)
+ CALL GetFaceElemType_Prism(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+CASE (Pyramid)
+ CALL GetFaceElemType_Pyramid(faceElemType=faceElemType, opt=opt, &
+ tFaceNodes=tFaceNodes, elemType=elemType, &
+ localFaceNumber=localFaceNumber)
+
+END SELECT
+END PROCEDURE GetFaceElemType2
+
!----------------------------------------------------------------------------
! MeasureSimplex
!----------------------------------------------------------------------------
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/Hexahedron/CMakeLists.txt b/src/submodules/Hexahedron/CMakeLists.txt
new file mode 100644
index 000000000..6347b7b77
--- /dev/null
+++ b/src/submodules/Hexahedron/CMakeLists.txt
@@ -0,0 +1,22 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferenceHexahedron_Method@Methods.F90
+ ${src_path}/HexahedronInterpolationUtility@Methods.F90)
diff --git a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90 b/src/submodules/Hexahedron/src/HexahedronInterpolationUtility@Methods.F90
similarity index 64%
rename from src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90
rename to src/submodules/Hexahedron/src/HexahedronInterpolationUtility@Methods.F90
index 4e1eb13d0..0bb3ab173 100644
--- a/src/submodules/Polynomial/src/HexahedronInterpolationUtility@Methods.F90
+++ b/src/submodules/Hexahedron/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/Geometry/src/ReferenceHexahedron_Method@Methods.F90 b/src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90
similarity index 95%
rename from src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90
rename to src/submodules/Hexahedron/src/ReferenceHexahedron_Method@Methods.F90
index 82e3b9346..e3a0cb997 100644
--- a/src/submodules/Geometry/src/ReferenceHexahedron_Method@Methods.F90
+++ b/src/submodules/Hexahedron/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
!----------------------------------------------------------------------------
@@ -597,7 +598,7 @@
! GetFaceElemType_Hexahedron
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Hexahedron
+MODULE PROCEDURE GetFaceElemType_Hexahedron1
INTEGER(I4B) :: elemType0
elemType0 = Input(default=Hexahedron8, option=elemType)
@@ -620,7 +621,31 @@
IF (PRESENT(tFaceNodes)) tFaceNodes(1:6) = 16_I4B
END SELECT
-END PROCEDURE GetFaceElemType_Hexahedron
+END PROCEDURE GetFaceElemType_Hexahedron1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Hexahedron
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Hexahedron2
+SELECT CASE (elemType)
+CASE (Hexahedron8)
+ faceElemType = Quadrangle4
+ tFaceNodes = 4_I4B
+
+CASE (Hexahedron20)
+ faceElemType = Quadrangle8
+ tFaceNodes = 8_I4B
+
+CASE (Hexahedron27)
+ faceElemType = Quadrangle9
+ tFaceNodes = 9_I4B
+
+CASE (Hexahedron64)
+ faceElemType = Quadrangle16
+ tFaceNodes = 16_I4B
+END SELECT
+END PROCEDURE GetFaceElemType_Hexahedron2
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90
index bcbeb6ae0..b063bfde7 100644
--- a/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90
+++ b/src/submodules/IntVector/src/IntVector_ConstructorMethod@Methods.F90
@@ -20,7 +20,9 @@
! summary: This submodule contains the contructor methods for [[IntVector_]]
SUBMODULE(IntVector_ConstructorMethod) Methods
-USE BaseMethod
+USE IntVector_SetMethod, ONLY: SetTotalDimension
+USE ReallocateUtility, ONLY: Util_Reallocate => Reallocate
+
IMPLICIT NONE
CONTAINS
@@ -29,216 +31,350 @@
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_shape
-IF (ALLOCATED(obj%Val)) THEN
- Ans(1) = SIZE(obj%Val)
-ELSE
- Ans = 0
-END IF
-END PROCEDURE intVec_shape
+MODULE PROCEDURE obj_shape
+LOGICAL(LGT) :: isok
+
+ans = 0
+isok = ALLOCATED(obj%val)
+IF (isok) ans(1) = SIZE(obj%val)
+END PROCEDURE obj_shape
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_Size
-IF (ALLOCATED(obj%Val)) THEN
- Ans = SIZE(obj%Val)
-ELSE
- Ans = 0
-END IF
-END PROCEDURE intVec_Size
+MODULE PROCEDURE obj_Size
+LOGICAL(LGT) :: isok
+
+ans = 0
+isok = ALLOCATED(obj%val)
+IF (isok) ans = SIZE(obj%val)
+END PROCEDURE obj_Size
!----------------------------------------------------------------------------
! getTotalDimension
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_getTotalDimension
+MODULE PROCEDURE obj_getTotalDimension
ans = obj%tDimension
-END PROCEDURE IntVec_getTotalDimension
+END PROCEDURE obj_getTotalDimension
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_AllocateData
-CALL Reallocate(obj%Val, Dims)
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_AllocateData
+MODULE PROCEDURE obj_AllocateData
+CALL Util_Reallocate(obj%val, dims)
+CALL SetTotalDimension(obj, 1_I4B)
+END PROCEDURE obj_AllocateData
!----------------------------------------------------------------------------
! Reallocate
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_Reallocate
-IF (ALLOCATED(obj)) THEN
- IF (SIZE(obj) .NE. row) THEN
- DEALLOCATE (obj)
- ALLOCATE (obj(row))
- END IF
-ELSE
+MODULE PROCEDURE obj_Reallocate
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tsize
+
+isok = ALLOCATED(obj)
+IF (.NOT. isok) THEN
ALLOCATE (obj(row))
+ RETURN
END IF
-END PROCEDURE intVec_Reallocate
+
+tsize = SIZE(obj)
+isok = tsize .NE. row
+IF (isok) THEN
+ DEALLOCATE (obj)
+ ALLOCATE (obj(row))
+END IF
+END PROCEDURE obj_Reallocate
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_Deallocate
-IF (ALLOCATED(obj%Val)) DEALLOCATE (obj%Val)
-END PROCEDURE intVec_Deallocate
+MODULE PROCEDURE obj_Deallocate
+LOGICAL(LGT) :: isok
+obj%tDimension = 0_I4B
+isok = ALLOCATED(obj%val)
+IF (isok) DEALLOCATE (obj%val)
+END PROCEDURE obj_Deallocate
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_initiate1
-CALL ALLOCATE (obj, tSize)
-END PROCEDURE intVec_initiate1
+MODULE PROCEDURE obj_initiate1
+CALL obj_AllocateData(obj=obj, dims=tSize)
+END PROCEDURE obj_initiate1
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_initiate2
+MODULE PROCEDURE obj_initiate2
INTEGER(I4B) :: n, i
+LOGICAL(LGT) :: isok
+
n = SIZE(tSize)
-IF (ALLOCATED(obj)) THEN
- IF (SIZE(obj) .NE. n) THEN
- DEALLOCATE (obj)
- ALLOCATE (obj(n))
- END IF
-ELSE
+isok = ALLOCATED(obj)
+
+IF (.NOT. isok) THEN
ALLOCATE (obj(n))
+ DO i = 1, n
+ CALL obj_AllocateData(obj=obj(i), dims=tSize(i))
+ END DO
+ RETURN
END IF
+
+i = SIZE(obj)
+isok = i .NE. n
+IF (isok) THEN
+ DEALLOCATE (obj)
+ ALLOCATE (obj(n))
+END IF
+
DO i = 1, n
- CALL ALLOCATE (obj(i), tSize(i))
+ CALL obj_AllocateData(obj=obj(i), dims=tSize(i))
END DO
-END PROCEDURE intVec_initiate2
+END PROCEDURE obj_initiate2
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_initiate3
-IF (ALLOCATED(obj%Val)) DEALLOCATE (obj%Val)
-ALLOCATE (obj%Val(a:b))
-obj%Val = 0
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate3
+MODULE PROCEDURE obj_initiate3
+LOGICAL(LGT) :: isok
+
+isok = ALLOCATED(obj%val)
+IF (isok) DEALLOCATE (obj%val)
+ALLOCATE (obj%val(a:b))
+obj%val(a:b) = 0
+CALL SetTotalDimension(obj, 1_I4B)
+END PROCEDURE obj_initiate3
!----------------------------------------------------------------------------
! Initiate
!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_initiate4a
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate4a
+MODULE PROCEDURE obj_initiate4a
+#include "./include/Initiate4.F90"
+END PROCEDURE obj_initiate4a
-MODULE PROCEDURE intVec_initiate4b
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate4b
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
-MODULE PROCEDURE intVec_initiate4c
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate4c
+MODULE PROCEDURE obj_initiate4b
+#include "./include/Initiate4.F90"
+END PROCEDURE obj_initiate4b
-MODULE PROCEDURE intVec_initiate4d
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate4d
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_initiate4c
+#include "./include/Initiate4.F90"
+END PROCEDURE obj_initiate4c
!----------------------------------------------------------------------------
-! Initiate
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_initiate4d
+#include "./include/Initiate4.F90"
+END PROCEDURE obj_initiate4d
+
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_initiate5a
+#include "./include/Initiate4.F90"
+END PROCEDURE obj_initiate5a
+
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_initiate5b
+#include "./include/Initiate4.F90"
+END PROCEDURE obj_initiate5b
+
!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Initiate6
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tsize
-MODULE PROCEDURE intVec_initiate5a
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate5a
+obj%tDimension = obj2%tDimension
+isok = ALLOCATED(obj2%val)
+IF (isok) THEN
+ tsize = SIZE(obj2%val)
+ CALL Util_Reallocate(obj%val, tsize)
+ CALL Copy_(x=obj%val, y=obj2%val)
+END IF
-MODULE PROCEDURE intVec_initiate5b
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE intVec_initiate5b
+END PROCEDURE obj_Initiate6
!----------------------------------------------------------------------------
! Vector
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_Constructor1
-CALL ALLOCATE (obj, tSize)
-END PROCEDURE IntVec_Constructor1
+MODULE PROCEDURE obj_Constructor1
+CALL obj_AllocateData(obj=obj, dims=tSize)
+END PROCEDURE obj_Constructor1
!----------------------------------------------------------------------------
! Vector_Pointer
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_Constructor2
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE IntVec_Constructor2
+MODULE PROCEDURE obj_Constructor2
+CALL Initiate(obj=obj, val=val)
+END PROCEDURE obj_Constructor2
!----------------------------------------------------------------------------
! Vector_Pointer
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_Constructor3
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE IntVec_Constructor3
+MODULE PROCEDURE obj_Constructor3
+CALL Initiate(obj=obj, val=val)
+END PROCEDURE obj_Constructor3
!----------------------------------------------------------------------------
! Vector_Pointer
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_Constructor_1
+MODULE PROCEDURE obj_Constructor_1
ALLOCATE (obj)
-CALL ALLOCATE (obj, tSize)
-END PROCEDURE IntVec_Constructor_1
+CALL Initiate(obj=obj, tsize=tsize)
+END PROCEDURE obj_Constructor_1
!----------------------------------------------------------------------------
! Vector
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_Constructor_2
+MODULE PROCEDURE obj_Constructor_2
ALLOCATE (obj)
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE IntVec_Constructor_2
+CALL Initiate(obj=obj, val=val)
+END PROCEDURE obj_Constructor_2
!----------------------------------------------------------------------------
! Vector
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_Constructor_3
+MODULE PROCEDURE obj_Constructor_3
ALLOCATE (obj)
-obj%Val = Val
-CALL setTotalDimension(obj, 1_I4B)
-END PROCEDURE IntVec_Constructor_3
+CALL Initiate(obj=obj, val=val)
+END PROCEDURE obj_Constructor_3
!----------------------------------------------------------------------------
! Assignment
!----------------------------------------------------------------------------
-MODULE PROCEDURE IntVec_assign_a
-IF (ALLOCATED(obj%Val)) THEN
- Val = obj%Val
-END IF
-END PROCEDURE IntVec_assign_a
+MODULE PROCEDURE obj_assign_a
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: tsize
+
+isok = ALLOCATED(obj%val)
+IF (.NOT. isok) RETURN
+
+tsize = SIZE(obj%val)
+CALL Util_Reallocate(val, tsize)
+CALL Copy_(x=val, y=obj%val)
+END PROCEDURE obj_assign_a
!----------------------------------------------------------------------------
! Convert
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_convert_int
-IF (ALLOCATED(From%Val)) THEN
- To = From%Val
-END IF
+CALL obj_assign_a(val=to, obj=from)
END PROCEDURE obj_convert_int
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy_Int8
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(y)
+CALL Util_Reallocate(x, tsize)
+
+DO CONCURRENT(ii=1:tsize)
+ x(ii) = y(ii)
+END DO
+END PROCEDURE obj_Copy_Int8
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy_Int16
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(y)
+CALL Util_Reallocate(x, tsize)
+
+DO CONCURRENT(ii=1:tsize)
+ x(ii) = y(ii)
+END DO
+END PROCEDURE obj_Copy_Int16
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy_Int32
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(y)
+CALL Util_Reallocate(x, tsize)
+
+DO CONCURRENT(ii=1:tsize)
+ x(ii) = y(ii)
+END DO
+END PROCEDURE obj_Copy_Int32
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy_Int64
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(y)
+CALL Util_Reallocate(x, tsize)
+
+DO CONCURRENT(ii=1:tsize)
+ x(ii) = y(ii)
+END DO
+END PROCEDURE obj_Copy_Int64
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy1_
+INTEGER(I4B) :: yy
+
+DO CONCURRENT(yy=y_start:y_end)
+ x(x_start + yy - y_start) = y(yy)
+END DO
+END PROCEDURE obj_Copy1_
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy2_
+INTEGER(I4B) :: tsize
+tsize = SIZE(y)
+CALL obj_Copy1_(x=x, y=y, x_start=1, y_start=1, y_end=tsize)
+END PROCEDURE obj_Copy2_
+
END SUBMODULE Methods
diff --git a/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90 b/src/submodules/IntVector/src/IntVector_GetMethod@Methods.F90
index 48e791fee..d797a0ae5 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,38 @@
!----------------------------------------------------------------------------
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
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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 +128,38 @@
!----------------------------------------------------------------------------
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
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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 +168,38 @@
!----------------------------------------------------------------------------
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
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
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
@@ -169,16 +208,31 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_10a
-#include "./include/intvec_get_10.inc"
+#include "./include/intvec_get_10.F90"
END PROCEDURE intVec_get_10a
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_10b
-#include "./include/intvec_get_10.inc"
+#include "./include/intvec_get_10.F90"
END PROCEDURE intVec_get_10b
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_10c
-#include "./include/intvec_get_10.inc"
+#include "./include/intvec_get_10.F90"
END PROCEDURE intVec_get_10c
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_10d
-#include "./include/intvec_get_10.inc"
+#include "./include/intvec_get_10.F90"
END PROCEDURE intVec_get_10d
!----------------------------------------------------------------------------
@@ -186,16 +240,31 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_11a
-#include "./include/intvec_get_11.inc"
+#include "./include/intvec_get_11.F90"
END PROCEDURE intVec_get_11a
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_11b
-#include "./include/intvec_get_11.inc"
+#include "./include/intvec_get_11.F90"
END PROCEDURE intVec_get_11b
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_11c
-#include "./include/intvec_get_11.inc"
+#include "./include/intvec_get_11.F90"
END PROCEDURE intVec_get_11c
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_11d
-#include "./include/intvec_get_11.inc"
+#include "./include/intvec_get_11.F90"
END PROCEDURE intVec_get_11d
!----------------------------------------------------------------------------
@@ -203,16 +272,31 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_12a
-#include "./include/intvec_get_12.inc"
+#include "./include/intvec_get_12.F90"
END PROCEDURE intVec_get_12a
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_12b
-#include "./include/intvec_get_12.inc"
+#include "./include/intvec_get_12.F90"
END PROCEDURE intVec_get_12b
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_12c
-#include "./include/intvec_get_12.inc"
+#include "./include/intvec_get_12.F90"
END PROCEDURE intVec_get_12c
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE intVec_get_12d
-#include "./include/intvec_get_12.inc"
+#include "./include/intvec_get_12.F90"
END PROCEDURE intVec_get_12d
!----------------------------------------------------------------------------
@@ -220,16 +304,29 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_13a
-#include "./include/intvec_get_13.inc"
+#include "./include/intvec_get_13.F90"
END PROCEDURE intVec_get_13a
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_13b
-#include "./include/intvec_get_13.inc"
+#include "./include/intvec_get_13.F90"
END PROCEDURE intVec_get_13b
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_get_13c
-#include "./include/intvec_get_13.inc"
+#include "./include/intvec_get_13.F90"
END PROCEDURE intVec_get_13c
+
+!----------------------------------------------------------------------------
+! get
+!----------------------------------------------------------------------------
+!
MODULE PROCEDURE intVec_get_13d
-#include "./include/intvec_get_13.inc"
+#include "./include/intvec_get_13.F90"
END PROCEDURE intVec_get_13d
!----------------------------------------------------------------------------
@@ -237,7 +334,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_getPointer_1
-Val => obj
+val => obj
END PROCEDURE intVec_getPointer_1
!----------------------------------------------------------------------------
@@ -245,15 +342,23 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_getPointer_2
-Val => obj%Val
+val => obj%val
END PROCEDURE intVec_getPointer_2
+!----------------------------------------------------------------------------
+! getPointer
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE intVec_getPointer_3
+val => obj%val
+END PROCEDURE intVec_getPointer_3
+
!----------------------------------------------------------------------------
! IndexOf
!----------------------------------------------------------------------------
MODULE PROCEDURE intVec_getIndex1
-Ans = MINLOC(ABS(obj%Val - val), 1)
+ans = MINLOC(ABS(obj%val - val), 1)
END PROCEDURE intVec_getIndex1
!----------------------------------------------------------------------------
@@ -262,19 +367,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/IntVector/src/include/Initiate4.F90 b/src/submodules/IntVector/src/include/Initiate4.F90
new file mode 100644
index 000000000..cddc52d4c
--- /dev/null
+++ b/src/submodules/IntVector/src/include/Initiate4.F90
@@ -0,0 +1,8 @@
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(val)
+CALL Util_Reallocate(obj%val, tsize)
+DO ii = 1, tsize
+ obj%val(ii) = INT(val(ii), kind=I4B)
+END DO
+CALL SetTotalDimension(obj, 1_I4B)
diff --git a/src/submodules/IntVector/src/include/intvec_get_10.inc b/src/submodules/IntVector/src/include/intvec_get_10.F90
similarity index 100%
rename from src/submodules/IntVector/src/include/intvec_get_10.inc
rename to src/submodules/IntVector/src/include/intvec_get_10.F90
diff --git a/src/submodules/IntVector/src/include/intvec_get_11.inc b/src/submodules/IntVector/src/include/intvec_get_11.F90
similarity index 100%
rename from src/submodules/IntVector/src/include/intvec_get_11.inc
rename to src/submodules/IntVector/src/include/intvec_get_11.F90
diff --git a/src/submodules/IntVector/src/include/intvec_get_12.inc b/src/submodules/IntVector/src/include/intvec_get_12.F90
similarity index 100%
rename from src/submodules/IntVector/src/include/intvec_get_12.inc
rename to src/submodules/IntVector/src/include/intvec_get_12.F90
diff --git a/src/submodules/IntVector/src/include/intvec_get_13.inc b/src/submodules/IntVector/src/include/intvec_get_13.F90
similarity index 100%
rename from src/submodules/IntVector/src/include/intvec_get_13.inc
rename to src/submodules/IntVector/src/include/intvec_get_13.F90
diff --git a/src/submodules/Line/CMakeLists.txt b/src/submodules/Line/CMakeLists.txt
new file mode 100644
index 000000000..430382110
--- /dev/null
+++ b/src/submodules/Line/CMakeLists.txt
@@ -0,0 +1,29 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/Line_Method@Methods.F90
+ ${src_path}/ReferenceLine_Method@Methods.F90
+ ${src_path}/LineInterpolationUtility@Methods.F90
+ ${src_path}/LineInterpolationUtility@BasisMethods.F90
+ ${src_path}/LineInterpolationUtility@OrthogonalMethods.F90
+ ${src_path}/LineInterpolationUtility@LagrangeMethods.F90
+ ${src_path}/LineInterpolationUtility@HierarchicalMethods.F90
+ ${src_path}/LineInterpolationUtility@QuadratureMethods.F90
+ ${src_path}/LineInterpolationUtility@InterpolationMethods.F90)
diff --git a/src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90
new file mode 100644
index 000000000..067dc1854
--- /dev/null
+++ b/src/submodules/Line/src/LineInterpolationUtility@BasisMethods.F90
@@ -0,0 +1,328 @@
+! 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(LineInterpolationUtility) BasisMethods
+USE BaseType, ONLY: polyopt => TypePolynomialOpt
+USE Display_Method, ONLY: ToString
+USE StringUtility, ONLY: UpperCase
+USE InputUtility, ONLY: Input
+USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, &
+ EvalAllOrthopol_
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "LineInterpolationUtility@BasisMethods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! EvalAll_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisEvalAll_Line1
+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(*), PARAMETER :: myName = "BasisEvalAll_Line1_()"
+LOGICAL(LGT) :: isok
+CHARACTER(1) :: astr
+#endif
+
+INTEGER(I4B) :: ii, basisType0, nrow, ncol
+REAL(DFP) :: temp(1, 100), x1(1)
+
+tsize = order + 1
+
+#ifdef DEBUG_VER
+isok = astr .EQ. "B"
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "refLine should be BIUNIT")
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+ ans(1) = 1.0_DFP
+ DO ii = 1, order
+ ans(ii + 1) = ans(ii) * x
+ END DO
+
+CASE DEFAULT
+
+#ifdef DEBUG_VER
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for basisType=Jacobi")
+ END IF
+
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ msg="lambda should be present for basisType=Ultraspherical")
+ END IF
+
+ isok = order + 1 .LE. SIZE(temp, 2)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "order+1 is greater than number of col in temp")
+#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_
+
+!----------------------------------------------------------------------------
+! 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_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "BasisGradientEvalAll_Line1_()"
+LOGICAL(LGT) :: isok
+#endif
+
+INTEGER(I4B) :: ii, basisType0
+CHARACTER(1) :: astr
+REAL(DFP) :: areal, breal, x1(1), temp(1, order + 1)
+
+tsize = order + 1
+
+astr = UpperCase(refline(1:1))
+
+#ifdef DEBUG_VER
+isok = astr .EQ. "B"
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "refline should be BIUNIT")
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+ ans(1) = 0.0_DFP
+ DO ii = 1, order
+ areal = REAL(ii, kind=DFP)
+ breal = x**(ii - 1)
+ ans(ii + 1) = areal * breal
+ END DO
+
+CASE DEFAULT
+
+#ifdef DEBUG_VER
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for basisType=Jacobi")
+ END IF
+
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for basisType=Ultraspherical")
+ END IF
+#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_
+
+!----------------------------------------------------------------------------
+! BasisGradientEvalAll_Line_
+!----------------------------------------------------------------------------
+
+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
+
+!----------------------------------------------------------------------------
+! BasisGradientEvalAll_Line_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisGradientEvalAll_Line2_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "BasisGradientEvalAll_Line2_()"
+LOGICAL(LGT) :: isok
+#endif
+
+INTEGER(I4B) :: ii, basisType0, jj
+REAL(DFP) :: areal, breal
+CHARACTER(1) :: astr
+
+nrow = SIZE(x)
+ncol = 1 + order
+
+astr = UpperCase(refLine(1:1))
+
+#ifdef DEBUG_VER
+isok = astr .EQ. "B"
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "refLine should be Biunit")
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+ ans(1:nrow, 1) = 0.0_DFP
+
+ DO ii = 1, order
+ 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
+
+#ifdef DEBUG_VER
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for basisType=Jacobi")
+ END IF
+
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for basisType=Ultraspherical")
+ END IF
+#endif
+
+ 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
+
+!----------------------------------------------------------------------------
+! BasisEvalAll_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BasisEvalAll_Line2_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "BasisEvalAll_Line2_()"
+LOGICAL(LGT) :: isok
+CHARACTER(1) :: astr
+#endif
+
+INTEGER(I4B) :: ii, basisType0
+
+nrow = SIZE(x)
+ncol = order + 1
+
+#ifdef DEBUG_VER
+astr = UpperCase(refline(1:1))
+isok = astr .EQ. "B"
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "refLine should be Biunit")
+#endif
+
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+ ans(1:nrow, 1) = 1.0_DFP
+ DO ii = 1, order
+ ans(1:nrow, ii + 1) = ans(1:nrow, ii) * x
+ END DO
+
+CASE DEFAULT
+
+#ifdef DEBUG_VER
+ IF (basisType0 .EQ. polyopt%Jacobi) THEN
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for basisType=Jacobi")
+ END IF
+
+ IF (basisType0 .EQ. polyopt%Ultraspherical) THEN
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for basisType=Ultraspherical")
+ END IF
+#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 BasisEvalAll_Line2_
+
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE BasisMethods
diff --git a/src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90
new file mode 100644
index 000000000..8e72a1b32
--- /dev/null
+++ b/src/submodules/Line/src/LineInterpolationUtility@HierarchicalMethods.F90
@@ -0,0 +1,170 @@
+! 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(LineInterpolationUtility) HierarchicalMethods
+USE BaseType, ONLY: polyopt => TypePolynomialOpt
+USE StringUtility, ONLY: UpperCase
+USE MappingUtility, ONLY: FromUnitLine2BiUnitLine_
+USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, &
+ EvalAllOrthopol_
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "LineInterpolationUtility@HierarchicalMethods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
+
+!----------------------------------------------------------------------------
+! 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))
+
+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
+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)
+
+CASE DEFAULT
+ dim1 = 0; dim2 = 0; dim3 = 0
+ RETURN
+END SELECT
+
+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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE HierarchicalMethods
diff --git a/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90
new file mode 100644
index 000000000..db12306a6
--- /dev/null
+++ b/src/submodules/Line/src/LineInterpolationUtility@InterpolationMethods.F90
@@ -0,0 +1,550 @@
+! 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(LineInterpolationUtility) InterpolationMethods
+USE BaseType, ONLY: ipopt => TypeInterpolationOpt
+USE MappingUtility, ONLY: FromBiunitLine2Segment_
+USE LegendrePolynomialUtility, ONLY: LegendreQuadrature
+USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature
+USE JacobiPolynomialUtility, ONLY: JacobiQuadrature
+USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature
+USE SortUtility, ONLY: HeapSort
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "LineInterpolationUtility@InterpolationMethods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! ToVEFC_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE ToVEFC_Line
+REAL(DFP) :: t1
+INTEGER(I4B) :: np
+LOGICAL(LGT) :: isok
+np = SIZE(pt)
+t1 = pt(np)
+isok = np .GT. 2
+IF (isok) THEN
+ pt(3:np) = pt(2:np - 1)
+ pt(2) = t1
+END IF
+END PROCEDURE ToVEFC_Line
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Line1
+INTEGER(I4B) :: tsize
+LOGICAL(LGT) :: isok
+
+isok = order .LE. 1_I4B
+IF (isok) THEN
+ ALLOCATE (ans(0))
+ RETURN
+END IF
+
+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, tsize
+ ans(ii) = xij(1) + REAL(ii, kind=dfp) * avar
+END DO
+END PROCEDURE EquidistanceInPoint_Line1_
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Line2
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+isok = order .LE. 1_I4B
+IF (isok) THEN
+ ALLOCATE (ans(0, 0))
+ RETURN
+END IF
+
+isok = PRESENT(xij)
+IF (isok) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 1_I4B
+END IF
+
+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
+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) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ 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
+
+ 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
+
+ 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
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+nrow = 1
+isok = PRESENT(xij)
+IF (isok) nrow = SIZE(xij, 1)
+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_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Line1_()"
+#endif
+
+REAL(DFP) :: temp(64)
+
+IF (order .EQ. 0_I4B) THEN
+ CALL EquidistancePoint_Line_(xij=xij, order=order, ans=ans, nrow=nrow, &
+ ncol=ncol)
+ RETURN
+END IF
+
+CALL handle_error
+!! handle_error is defined in this routine, see below
+
+ncol = order + 1
+
+SELECT CASE (ipType)
+
+CASE (ipopt%Equidistance)
+ CALL EquidistancePoint_Line_(xij=xij, order=order, nrow=nrow, ncol=ncol, &
+ ans=ans)
+ CALL handle_increasing
+
+CASE (ipopt%GaussLegendre)
+ CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussChebyshev)
+ CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussLegendreLobatto)
+ CALL LegendreQuadrature(n=ncol, pt=temp(1:ncol), &
+ quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussChebyshevLobatto)
+ CALL Chebyshev1Quadrature(n=ncol, pt=temp(1:ncol), &
+ quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussJacobi)
+ CALL JacobiQuadrature(n=ncol, pt=temp(1:ncol), quadType=ipopt%Gauss, &
+ alpha=alpha, beta=beta)
+ CALL handle_non_equidistance
+
+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
+
+CASE (ipopt%GaussUltraspherical)
+ CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), &
+ quadType=ipopt%Gauss, lambda=lambda)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussUltrasphericalLobatto)
+ CALL UltrasphericalQuadrature(n=ncol, pt=temp(1:ncol), &
+ quadType=ipopt%GaussLobatto, lambda=lambda)
+
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ ! AssertError1(a, myName, modName, lineNo, msg)
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "Unknown iptype")
+#endif
+
+END SELECT
+
+CONTAINS
+
+SUBROUTINE handle_vefc
+ REAL(DFP) :: t1
+ !! layout VEFC
+ IF (layout(1:1) .EQ. "V") THEN
+ t1 = temp(order + 1)
+ IF (order .GE. 2) THEN
+ temp(3:order + 1) = temp(2:order)
+ END IF
+ temp(2) = t1
+ END IF
+END SUBROUTINE handle_vefc
+
+SUBROUTINE handle_increasing
+ INTEGER(I4B) :: ii
+ !! layout INCREASING
+ IF (layout(1:1) .EQ. "I") THEN
+ DO ii = 1, nrow
+ CALL HeapSort(ans(ii, 1:ncol))
+ END DO
+ END IF
+END SUBROUTINE
+
+SUBROUTINE handle_non_equidistance
+ IF (PRESENT(xij)) THEN
+ CALL FromBiunitLine2Segment_(xin=temp(1:ncol), x1=xij(:, 1), &
+ x2=xij(:, 2), ans=ans, nrow=nrow, ncol=ncol)
+ ELSE
+ nrow = 1
+ ans(1, 1:ncol) = temp(1:ncol)
+ END IF
+END SUBROUTINE handle_non_equidistance
+
+SUBROUTINE handle_error
+#ifdef DEBUG_VER
+ LOGICAL(LGT) :: isok
+
+ SELECT CASE (ipType)
+ CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto)
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for ipType=GaussJacobi")
+
+ CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto)
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for ipType=GaussUltraSpherical")
+ END SELECT
+#endif
+
+END SUBROUTINE handle_error
+
+END PROCEDURE InterpolationPoint_Line1_
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Line_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Line2_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Line2_()"
+#endif
+
+tsize = order + 1
+IF (order .EQ. 0_I4B) THEN
+ ans(1) = 0.5_DFP * (xij(1) + xij(2))
+ RETURN
+END IF
+
+CALL handle_error
+
+SELECT CASE (ipType)
+
+CASE (ipopt%Equidistance)
+ CALL EquidistancePoint_Line_(xij=xij, order=order, tsize=tsize, ans=ans)
+
+ IF (layout(1:2) .EQ. "IN") CALL HeapSort(ans(1:tsize))
+
+CASE (ipopt%GaussLegendre)
+ CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussChebyshev)
+ CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%Gauss)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussJacobi)
+ CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, alpha=alpha, &
+ beta=beta)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussUltraspherical)
+ CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%Gauss, &
+ lambda=lambda)
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussLegendreLobatto)
+ CALL LegendreQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussChebyshevLobatto)
+ CALL Chebyshev1Quadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto)
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussJacobiLobatto)
+ CALL JacobiQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, alpha=alpha, &
+ beta=beta)
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+CASE (ipopt%GaussUltrasphericalLobatto)
+ CALL UltrasphericalQuadrature(n=tsize, pt=ans, quadType=ipopt%GaussLobatto, &
+ lambda=lambda)
+ CALL handle_vefc
+ CALL handle_non_equidistance
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, "Unknown ipType")
+#endif
+
+END SELECT
+
+CONTAINS
+
+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)
+ END IF
+ ans(2) = t1
+ END IF
+
+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
+
+ SELECT CASE (ipType)
+ CASE (ipopt%GaussJacobi, ipopt%GaussJacobiLobatto)
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for ipType=GaussJacobi")
+
+ CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto)
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for ipType=GaussUltraSpherical")
+ END SELECT
+
+#endif
+
+END SUBROUTINE handle_error
+
+END PROCEDURE InterpolationPoint_Line2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE InterpolationMethods
diff --git a/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90
new file mode 100644
index 000000000..420153623
--- /dev/null
+++ b/src/submodules/Line/src/LineInterpolationUtility@LagrangeMethods.F90
@@ -0,0 +1,457 @@
+! 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(LineInterpolationUtility) LagrangeMethods
+USE BaseType, ONLY: polyopt => TypePolynomialOpt, elmopt => TypeElemNameOpt
+USE Display_Method, ONLY: ToString, Display
+USE InputUtility, ONLY: Input
+USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat
+USE F95_BLAS, ONLY: GEMM
+USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, &
+ EvalAllOrthopol_
+USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "LineInterpolationUtility@LagrangeMethods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Line
+INTEGER(I4B) :: ii, n
+n = LagrangeDOF_Line(order=order)
+ALLOCATE (ans(n, 1))
+DO ii = 1, n
+ ans(ii, 1) = ii - 1
+END DO
+END PROCEDURE LagrangeDegree_Line
+
+!----------------------------------------------------------------------------
+! LagrangeDOF_Point
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDOF_Point
+ans = 1_I4B
+END PROCEDURE LagrangeDOF_Point
+
+!----------------------------------------------------------------------------
+! LagrangeDOF_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDOF_Line
+ans = order + 1
+END PROCEDURE LagrangeDOF_Line
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeInDOF_Line
+ans = order - 1_I4B
+END PROCEDURE LagrangeInDOF_Line
+
+!----------------------------------------------------------------------------
+! GetTotalDOF_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalDOF_Line
+ans = order + 1
+END PROCEDURE GetTotalDOF_Line
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalInDOF_Line
+ans = order - 1_I4B
+IF (ans .LT. 0_I4B) ans = 0_I4B
+END PROCEDURE GetTotalInDOF_Line
+
+!----------------------------------------------------------------------------
+! 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, 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
+
+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) :: 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
+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
+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_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line1_()"
+LOGICAL(LGT) :: isok
+#endif
+
+LOGICAL(LGT) :: firstCall0
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(1, SIZE(xij, 2)), x1(1)
+INTEGER(I4B) :: ii, orthopol0, nrow, ncol
+
+tsize = SIZE(xij, 2)
+
+#ifdef DEBUG_VER
+isok = tsize .EQ. order + 1
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ 'Size(xij, 1)='//ToString(tsize)//' .NE. order+1 = '//ToString(order + 1))
+#endif
+
+orthopol0 = Input(default=polyopt%Monomial, option=basisType)
+firstCall0 = Input(default=.TRUE., option=firstCall)
+
+! make coeff0
+
+IF (PRESENT(coeff)) THEN
+ IF (firstCall0) THEN
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff, nrow=nrow, ncol=ncol)
+ END IF
+ coeff0(1:tsize, 1:tsize) = coeff(1:tsize, 1:tsize)
+
+ELSE
+ CALL LagrangeCoeff_Line_(order=order, xij=xij, basisType=orthopol0, &
+ alpha=alpha, beta=beta, lambda=lambda, &
+ ans=coeff0, nrow=nrow, ncol=ncol)
+END IF
+
+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
+
+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 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) :: isok, firstCall0
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2))
+
+firstCall0 = Input(default=.TRUE., option=firstCall)
+isok = PRESENT(coeff)
+
+IF (isok) THEN
+
+ CALL LagrangeEvalAll_Line_( &
+ order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff, &
+ xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+ELSE
+
+ CALL LagrangeEvalAll_Line_( &
+ order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff0, &
+ xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+END IF
+END PROCEDURE LagrangeEvalAll_Line2_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Line_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Line3_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "LagrangeEvalAll_Line3_()"
+LOGICAL(LGT) :: isok
+#endif
+
+INTEGER(I4B) :: orthopol0, xx_i, xx_j, coeff_i, coeff_j
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
+
+#ifdef DEBUG_VER
+isok = ncol .EQ. order + 1
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ 'Size(xij, 2)='//ToString(ncol)//' .NE. order+1 = '//ToString(order + 1))
+#endif
+
+orthopol0 = Input(default=polyopt%Monomial, option=basisType)
+
+IF (firstCall) THEN
+ CALL LagrangeCoeff_Line_( &
+ order=order, xij=xij, basisType=orthopol0, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=coeff, nrow=coeff_i, ncol=coeff_j)
+END IF
+
+CALL EvalAllOrthopol_( &
+ n=order, x=x(1, 1:nrow), orthopol=orthopol0, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=xx, nrow=xx_i, ncol=xx_j)
+
+! ans = MATMUL(xx, coeff0)
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx(1:nrow, 1:ncol), &
+ B=coeff(1:ncol, 1:ncol))
+
+END PROCEDURE LagrangeEvalAll_Line3_
+
+!----------------------------------------------------------------------------
+! LagrangeGradientEvalAll_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Line1
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL LagrangeGradientEvalAll_Line_( &
+ 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_Line1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Line1_
+LOGICAL(LGT) :: firstCall0, iscoeff
+REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1)
+INTEGER(I4B) :: basisType0
+
+firstCall0 = Input(default=.TRUE., option=firstCall)
+basisType0 = Input(default=polyopt%Monomial, option=basisType)
+iscoeff = PRESENT(coeff)
+
+IF (iscoeff) THEN
+ CALL LagrangeGradientEvalAll_Line_( &
+ order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ coeff=coeff, xx=xx, firstCall=firstCall0, basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda)
+
+ELSE
+
+ CALL LagrangeGradientEvalAll_Line_( &
+ order=order, x=x, xij=xij, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ coeff=coeff0, xx=xx, firstCall=firstCall0, basisType=basisType0, &
+ alpha=alpha, beta=beta, lambda=lambda)
+
+END IF
+
+END PROCEDURE LagrangeGradientEvalAll_Line1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeGradientEvalAll_Line2_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "LagrangeGradientEvalAll_Line2_()"
+#endif
+
+! coeff0(order + 1, order + 1)
+! xx(SIZE(x, 2), order + 1)
+
+INTEGER(I4B) :: indx(2)
+
+dim1 = SIZE(x, 2) !! nips
+dim2 = SIZE(xij, 2) !! tdof
+dim3 = 1
+
+indx(1) = dim2
+indx(2) = dim2
+
+IF (firstCall) THEN
+ CALL LagrangeCoeff_Line_( &
+ order=order, xij=xij, basisType=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=coeff, nrow=indx(1), ncol=indx(2))
+END IF
+
+CALL GradientEvalAllOrthopol_( &
+ n=order, x=x(1, 1:dim1), orthopol=basisType, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=xx, nrow=dim1, ncol=dim2)
+
+CALL GEMM(C=ans(1:dim1, 1:dim2, 1), alpha=1.0_DFP, A=xx(1:dim1, 1:dim2), &
+ B=coeff(1:indx(1), 1:indx(2)))
+END PROCEDURE LagrangeGradientEvalAll_Line2_
+
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE LagrangeMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90
similarity index 60%
rename from src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90
rename to src/submodules/Line/src/LineInterpolationUtility@Methods.F90
index 30baa84be..b022b17ea 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@AbsMethods.F90
+++ b/src/submodules/Line/src/LineInterpolationUtility@Methods.F90
@@ -15,37 +15,16 @@
! along with this program. If not, see
!
-#define _ELEM_METHOD_ ABS
-
-SUBMODULE(FEVariable_Method) AbsMethods
-USE BaseMethod
+SUBMODULE(LineInterpolationUtility) Methods
IMPLICIT NONE
CONTAINS
!----------------------------------------------------------------------------
-! Abs
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE fevar_Abs
-SELECT CASE (obj%rank)
-!!
-CASE (SCALAR)
-#include "./ScalarElemMethod.inc"
-!!
-CASE (VECTOR)
-#include "./VectorElemMethod.inc"
-!!
-CASE (MATRIX)
-#include "./MatrixElemMethod.inc"
-!!
-END SELECT
-!!
-END PROCEDURE fevar_Abs
-
-!----------------------------------------------------------------------------
-!
+! RefElemDomain_Line
!----------------------------------------------------------------------------
-END SUBMODULE AbsMethods
+MODULE PROCEDURE RefElemDomain_Line
+ans = "BIUNIT"
+END PROCEDURE RefElemDomain_Line
-#undef _ELEM_METHOD_
+END SUBMODULE Methods
diff --git a/src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90
new file mode 100644
index 000000000..dd49aa037
--- /dev/null
+++ b/src/submodules/Line/src/LineInterpolationUtility@OrthogonalMethods.F90
@@ -0,0 +1,156 @@
+! 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(LineInterpolationUtility) OrthogonalMethods
+USE BaseType, ONLY: polyopt => TypePolynomialOpt
+USE StringUtility, ONLY: UpperCase
+USE MappingUtility, ONLY: FromUnitLine2BiUnitLine_
+USE OrthogonalPolynomialUtility, ONLY: GradientEvalAllOrthopol_, &
+ EvalAllOrthopol_
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "LineInterpolationUtility@OrthogonalMethods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! OrthogonalBasis_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalBasis_Line1
+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
+
+!----------------------------------------------------------------------------
+! OrthogonalBasis_Line1_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalBasis_Line1_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "OrthogonalBasis_Line1_()"
+LOGICAL(LGT) :: isok, abool
+#endif
+
+CHARACTER(1) :: astr
+REAL(DFP) :: x(SIZE(xij, 2))
+
+nrow = SIZE(xij, 2)
+ncol = order + 1
+ans(1:nrow, 1:ncol) = 0.0_DFP
+
+#ifdef DEBUG_VER
+abool = basisType .EQ. polyopt%Jacobi
+IF (abool) THEN
+ isok = PRESENT(alpha) .AND. PRESENT(beta)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for basisType=Jacobi")
+END IF
+
+abool = basisType .EQ. polyopt%Ultraspherical
+IF (abool) THEN
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for basisType=Ultraspherical")
+END IF
+#endif
+
+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)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "No case found for refLine.")
+#endif
+END SELECT
+END PROCEDURE OrthogonalBasis_Line1_
+
+!----------------------------------------------------------------------------
+! OrthogonalBasisGradient_Line1
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OrthogonalBasisGradient_Line1
+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_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "OrthogonalBasisGradient_Line1_()"
+#endif
+
+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)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "No case found for refline")
+#endif
+END SELECT
+END PROCEDURE OrthogonalBasisGradient_Line1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE OrthogonalMethods
diff --git a/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90
new file mode 100644
index 000000000..21c8daaf6
--- /dev/null
+++ b/src/submodules/Line/src/LineInterpolationUtility@QuadratureMethods.F90
@@ -0,0 +1,284 @@
+! 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(LineInterpolationUtility) QuadratureMethods
+USE BaseType, ONLY: ipopt => TypeInterpolationOpt, &
+ qpopt => TypeQuadratureOpt
+USE MappingUtility, ONLY: FromBiunitLine2Segment_
+USE LegendrePolynomialUtility, ONLY: LegendreQuadrature
+USE Chebyshev1PolynomialUtility, ONLY: Chebyshev1Quadrature
+USE JacobiPolynomialUtility, ONLY: JacobiQuadrature
+USE UltrasphericalPolynomialUtility, ONLY: UltrasphericalQuadrature
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "LineInterpolationUtility@QuadratureMethods.F90"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! QuadratureNumber_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadratureNumber_Line
+SELECT CASE (quadType)
+CASE (qpopt%GaussLegendre, qpopt%GaussChebyshev, &
+ qpopt%GaussJacobi, qpopt%GaussUltraspherical)
+ ans = 1_I4B + INT(order / 2, kind=I4B)
+CASE (qpopt%GaussLegendreRadauRight, qpopt%GaussLegendreRadauLeft, &
+ qpopt%GaussChebyshevRadauLeft, qpopt%GaussChebyshevRadauRight, &
+ qpopt%GaussJacobiRadauLeft, qpopt%GaussJacobiRadauRight, &
+ qpopt%GaussUltraSphericalRadauLeft, qpopt%GaussUltraSphericalRadauRight)
+ ans = 2_I4B + INT((order - 1) / 2, kind=I4B)
+CASE DEFAULT
+ ans = 2_I4B + INT(order / 2, kind=I4B)
+END SELECT
+END PROCEDURE QuadratureNumber_Line
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Line1
+INTEGER(I4B) :: nips(1), nrow, ncol
+LOGICAL(LGT) :: isok
+
+nips(1) = QuadratureNumber_Line(order=order, quadType=quadType)
+
+isok = PRESENT(xij)
+nrow = 1
+IF (isok) nrow = SIZE(xij, 1)
+
+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
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Line2
+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
+LOGICAL(LGT) :: isok
+
+nrow = 1
+isok = PRESENT(xij)
+IF (isok) nrow = SIZE(xij, 1)
+
+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
+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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Line1_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "QuadraturePoint_Line1_()"
+#endif
+
+INTEGER(I4B) :: np, nsd, ii, jj
+REAL(DFP) :: areal
+LOGICAL(LGT) :: changeLayout, isok
+
+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)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "alpha and beta should be present for quadType=ipopt%GaussJacobi")
+
+CASE (ipopt%GaussUltraSpherical, ipopt%GaussUltraSphericalLobatto, &
+ ipopt%GaussUltraSphericalRadauLeft, ipopt%GaussUltraSphericalRadauRight)
+
+ isok = PRESENT(lambda)
+ CALL AssertError1(isok, myName, modName, __LINE__, &
+ "lambda should be present for quadType=ipopt%GaussUltraspherical")
+END SELECT
+#endif
+
+nsd = 1
+isok = PRESENT(xij)
+IF (isok) nsd = SIZE(xij, 1)
+
+np = nips(1)
+nrow = nsd + 1
+ncol = nips(1)
+
+isok = layout(1:1) .EQ. "V"
+changeLayout = .FALSE.
+IF (isok) changeLayout = .TRUE.
+
+SELECT CASE (quadType)
+
+CASE (ipopt%GaussLegendre)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%Gauss)
+
+CASE (ipopt%GaussLegendreRadauLeft)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft)
+
+CASE (ipopt%GaussLegendreRadauRight)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauRight)
+
+CASE (ipopt%GaussLegendreLobatto)
+ CALL LegendreQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussLobatto)
+
+CASE (ipopt%GaussChebyshev)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%Gauss)
+
+CASE (ipopt%GaussChebyshevRadauLeft)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft)
+
+CASE (ipopt%GaussChebyshevRadauRight)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauRight)
+
+CASE (ipopt%GaussChebyshevLobatto)
+ CALL Chebyshev1Quadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussLobatto)
+
+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 (ipopt%GaussJacobiRadauLeft)
+ CALL JacobiQuadrature(n=np, pt=ans(1, 1:ncol), wt=ans(nrow, 1:ncol), &
+ quadType=ipopt%GaussRadauLeft, alpha=alpha, beta=beta)
+
+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 (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)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "Unknown iptype")
+#endif
+END SELECT
+
+IF (changeLayout) THEN
+ CALL ToVEFC_Line(ans(1, 1:ncol))
+ CALL ToVEFC_Line(ans(nrow, 1:ncol))
+END IF
+
+IF (PRESENT(xij)) THEN
+ 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
+END IF
+END PROCEDURE QuadraturePoint_Line1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE QuadratureMethods
diff --git a/src/submodules/Line/src/Line_Method@Methods.F90 b/src/submodules/Line/src/Line_Method@Methods.F90
new file mode 100644
index 000000000..3775f5f17
--- /dev/null
+++ b/src/submodules/Line/src/Line_Method@Methods.F90
@@ -0,0 +1,556 @@
+! 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(Line_Method) Methods
+USE BaseMethod
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE line_exp_is_degenerate_nd
+ans = (ALL(p1(1:dim_num) == p2(1:dim_num)))
+END PROCEDURE line_exp_is_degenerate_nd
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE line_exp2imp_2d
+INTEGER(i4b), PARAMETER :: dim_num = 2
+REAL(dfp) norm
+!
+! Take care of degenerate cases.
+!
+IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) THEN
+ RETURN
+END IF
+
+a = p2(2) - p1(2)
+b = p1(1) - p2(1)
+c = p2(1) * p1(2) - p1(1) * p2(2)
+
+norm = a * a + b * b + c * c
+
+IF (0.0D+00 < norm) THEN
+ a = a / norm
+ b = b / norm
+ c = c / norm
+END IF
+
+IF (a < 0.0D+00) THEN
+ a = -a
+ b = -b
+ c = -c
+END IF
+
+END PROCEDURE line_exp2imp_2d
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE line_imp_is_degenerate_2d
+ans = (a * a + b * b == 0.0D+00)
+END PROCEDURE line_imp_is_degenerate_2d
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE lines_imp_int_2d
+INTEGER(kind=4), PARAMETER :: dim_num = 2
+REAL(kind=8) a(dim_num, dim_num + 1)
+INTEGER(kind=4) info
+!
+p(1:dim_num) = 0.0D+00
+!
+! Refuse to handle degenerate lines.
+!
+IF (line_imp_is_degenerate_2d(a1, b1, c1)) THEN
+ ival = -1
+ RETURN
+END IF
+!
+IF (line_imp_is_degenerate_2d(a2, b2, c2)) THEN
+ ival = -2
+ RETURN
+END IF
+!
+! Set up and solve a linear system.
+!
+a(1, 1) = a1
+a(1, 2) = b1
+a(1, 3) = -c1
+a(2, 1) = a2
+a(2, 2) = b2
+a(2, 3) = -c2
+!
+CALL r8mat_solve(2, 1, a, info)
+!
+! If the inverse exists, then the lines intersect at the solution point.
+!
+IF (info == 0) THEN
+
+ ival = 1
+ p(1:dim_num) = a(1:dim_num, 3)
+!
+! If the inverse does not exist, then the lines are parallel
+! or coincident. Check for parallelism by seeing if the
+! C entries are in the same ratio as the A or B entries.
+!
+ELSE
+ ival = 0
+ IF (a1 == 0.0D+00) THEN
+ IF (b2 * c1 == c2 * b1) THEN
+ ival = 2
+ END IF
+ ELSE
+ IF (a2 * c1 == c2 * a1) THEN
+ ival = 2
+ END IF
+ END IF
+END IF
+!
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE line_exp_perp_2d
+INTEGER(kind=4), PARAMETER :: dim_num = 2
+REAL(kind=8) bot
+REAL(kind=8) t
+!
+flag = .FALSE.
+IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) THEN
+ flag = .TRUE.
+ p4(1:2) = r8_huge()
+ RETURN
+END IF
+!
+bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2)
+!
+! (P3-P1) dot (P2-P1) = Norm(P3-P1) * Norm(P2-P1) * Cos(Theta).
+!
+! (P3-P1) dot (P2-P1) / Norm(P3-P1)^2 = normalized coordinate T
+! of the projection of (P3-P1) onto (P2-P1).
+!
+t = SUM((p1(1:dim_num) - p3(1:dim_num)) &
+ * (p1(1:dim_num) - p2(1:dim_num))) / bot
+!
+p4(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
+!
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE lines_exp_int_2d
+INTEGER(kind=4), PARAMETER :: dim_num = 2
+REAL(kind=8) a1
+REAL(kind=8) a2
+REAL(kind=8) b1
+REAL(kind=8) b2
+REAL(kind=8) c1
+REAL(kind=8) c2
+LOGICAL(kind=4) point_1
+LOGICAL(kind=4) point_2
+!
+ival = 0
+p(1:dim_num) = 0.0D+00
+!
+! Check whether either line is a point.
+!
+IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN
+ point_1 = .TRUE.
+ELSE
+ point_1 = .FALSE.
+END IF
+
+IF (ALL(q1(1:dim_num) == q2(1:dim_num))) THEN
+ point_2 = .TRUE.
+ELSE
+ point_2 = .FALSE.
+END IF
+!
+! Convert the lines to ABC format.
+!
+IF (.NOT. point_1) THEN
+ CALL line_exp2imp_2d(p1, p2, a1, b1, c1)
+END IF
+
+IF (.NOT. point_2) THEN
+ CALL line_exp2imp_2d(q1, q2, a2, b2, c2)
+END IF
+!
+! Search for intersection of the lines.
+!
+IF (point_1 .AND. point_2) THEN
+ IF (ALL(p1(1:dim_num) == q1(1:dim_num))) THEN
+ ival = 1
+ p(1:dim_num) = p1(1:dim_num)
+ END IF
+ELSE IF (point_1) THEN
+ IF (a2 * p1(1) + b2 * p1(2) == c2) THEN
+ ival = 1
+ p(1:dim_num) = p1(1:dim_num)
+ END IF
+ELSE IF (point_2) THEN
+ IF (a1 * q1(1) + b1 * q1(2) == c1) THEN
+ ival = 1
+ p(1:dim_num) = q1(1:dim_num)
+ END IF
+ELSE
+ CALL lines_imp_int_2d(a1, b1, c1, a2, b2, c2, ival, p)
+END IF
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE segment_point_dist_2d
+INTEGER(kind=4), PARAMETER :: dim_num = 2
+REAL(kind=8) bot
+REAL(kind=8) pn(dim_num)
+REAL(kind=8) t
+!
+! If the line segment is actually a point, then the answer is easy.
+!
+IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN
+ t = 0.0D+00
+ELSE
+ bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2)
+ t = SUM((p(1:dim_num) - p1(1:dim_num)) &
+ * (p2(1:dim_num) - p1(1:dim_num))) / bot
+ t = MAX(t, 0.0D+00)
+ t = MIN(t, 1.0D+00)
+END IF
+!
+pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
+dist = SQRT(SUM((p(1:dim_num) - pn(1:dim_num))**2))
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE segment_point_dist_3d
+INTEGER(i4b), PARAMETER :: dim_num = 3
+REAL(dfp) bot
+REAL(dfp) pn(dim_num)
+REAL(dfp) t
+!
+! If the line segment is actually a point, then the answer is easy.
+!
+IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN
+ t = 0.0D+00
+ELSE
+ bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2)
+ t = SUM((p(1:dim_num) - p1(1:dim_num)) &
+ * (p2(1:dim_num) - p1(1:dim_num))) / bot
+ t = MAX(t, 0.0D+00)
+ t = MIN(t, 1.0D+00)
+END IF
+
+pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
+dist = SQRT(SUM((p(1:dim_num) - pn(1:dim_num))**2))
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE line_exp_point_dist_signed_2d
+INTEGER(kind=4), PARAMETER :: dim_num = 2
+REAL(kind=8) a
+REAL(kind=8) b
+REAL(kind=8) c
+!
+! If the explicit line degenerates to a point, the computation is easy.
+!
+IF (line_exp_is_degenerate_nd(dim_num, p1, p2)) THEN
+ dist_signed = SQRT(SUM((p1(1:dim_num) - p(1:dim_num))**2))
+!
+! Convert the explicit line to the implicit form A * P(1) + B * P(2) + C = 0.
+! This makes the computation of the signed distance to (X,Y) easy.
+!
+ELSE
+ a = p2(2) - p1(2)
+ b = p1(1) - p2(1)
+ c = p2(1) * p1(2) - p1(1) * p2(2)
+ dist_signed = (a * p(1) + b * p(2) + c) / SQRT(a * a + b * b)
+END IF
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE segment_point_near_2d
+INTEGER(kind=4), PARAMETER :: dim_num = 2
+REAL(kind=8) bot
+!
+! If the line segment is actually a point, then the answer is easy.
+!
+IF (ALL(p1(1:dim_num) == p2(1:dim_num))) THEN
+ t = 0.0D+00
+ELSE
+ bot = SUM((p2(1:dim_num) - p1(1:dim_num))**2)
+ t = SUM((p(1:dim_num) - p1(1:dim_num)) &
+ * (p2(1:dim_num) - p1(1:dim_num))) / bot
+ t = MAX(t, 0.0D+00)
+ t = MIN(t, 1.0D+00)
+END IF
+!
+pn(1:dim_num) = p1(1:dim_num) + t * (p2(1:dim_num) - p1(1:dim_num))
+dist = SQRT(SUM((p(1:dim_num) - pn(1:dim_num))**2))
+END PROCEDURE
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Aug 2022
+! summary: r8mat solve
+!
+!# Introduction
+!
+! Input, integer ( kind = 4 ) N, the order of the matrix.
+!
+! Input, integer ( kind = 4 ) RHS_NUM, the number of right hand sides.
+! RHS_NUM must be at least 0.
+!
+! Input/output, real ( kind = 8 ) A(N,N+rhs_num), contains in rows and
+! columns 1 to N the coefficient matrix, and in columns N+1 through
+! N+rhs_num, the right hand sides. On output, the coefficient matrix
+! area has been destroyed, while the right hand sides have
+! been overwritten with the corresponding solutions.
+!
+! Output, integer ( kind = 4 ) INFO, singularity flag.
+! 0, the matrix was not singular, the solutions were computed;
+! J, factorization failed on step J, and the solutions could not
+! be computed.
+
+PURE SUBROUTINE r8mat_solve(n, rhs_num, a, info)
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B), INTENT(IN) :: rhs_num
+ REAL(DFP), INTENT(INOUT) :: a(n, n + rhs_num)
+ INTEGER(I4B), INTENT(OUT) :: info
+ !!
+ REAL(DFP) :: apivot
+ REAL(DFP) :: factor
+ INTEGER(I4B) :: i
+ INTEGER(I4B) :: ipivot
+ INTEGER(I4B) :: j
+ !!
+ info = 0
+ !!
+ DO j = 1, n
+ !
+ ! Choose a pivot row.
+ !
+ ipivot = j
+ apivot = a(j, j)
+ !
+ DO i = j + 1, n
+ IF (ABS(apivot) < ABS(a(i, j))) THEN
+ apivot = a(i, j)
+ ipivot = i
+ END IF
+ END DO
+ !
+ IF (apivot == 0.0D+00) THEN
+ info = j
+ RETURN
+ END IF
+ !
+ ! Interchange.
+ !
+ DO i = 1, n + rhs_num
+ CALL swap(a(ipivot, i), a(j, i))
+ END DO
+ !
+ ! A(J,J) becomes 1.
+ !
+ a(j, j) = 1.0D+00
+ a(j, j + 1:n + rhs_num) = a(j, j + 1:n + rhs_num) / apivot
+ !
+ ! A(I,J) becomes 0.
+ !
+ DO i = 1, n
+ IF (i /= j) THEN
+ factor = a(i, j)
+ a(i, j) = 0.0D+00
+ a(i,j+1:n+rhs_num) = a(i,j+1:n+rhs_num) - factor * a(j,j+1:n+rhs_num)
+ END IF
+ END DO
+ END DO
+END SUBROUTINE r8mat_solve
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION r8vec_normsq_affine(n, v0, v1) RESULT(ans)
+ INTEGER(i4b), INTENT(in) :: n
+ REAL(dfp), INTENT(in) :: v0(n)
+ REAL(dfp), INTENT(in) :: v1(n)
+ REAL(dfp) :: ans
+ ans = SUM((v0(1:n) - v1(1:n))**2)
+END FUNCTION r8vec_normsq_affine
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_wrap(ival, ilo, ihi) RESULT(ans)
+ INTEGER(i4b), INTENT(in) :: ival
+ INTEGER(i4b), INTENT(in) :: ilo
+ INTEGER(i4b), INTENT(in) :: ihi
+ INTEGER(i4b) :: ans
+ !!
+ INTEGER(i4b) :: jhi
+ INTEGER(i4b) :: jlo
+ INTEGER(i4b) :: wide
+ !!
+ jlo = MIN(ilo, ihi)
+ jhi = MAX(ilo, ihi)
+ !!
+ wide = jhi - jlo + 1
+ !!
+ IF (wide == 1) THEN
+ ans = jlo
+ ELSE
+ ans = jlo + i4_modp(ival - jlo, wide)
+ END IF
+ !!
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_modp(i, j) RESULT(ans)
+ INTEGER(i4b), INTENT(IN) :: i
+ INTEGER(i4b), INTENT(IN) :: j
+ INTEGER(i4b) :: ans
+ IF (j == 0) THEN
+ RETURN
+ END IF
+ ans = MOD(i, j)
+ IF (ans < 0) THEN
+ ans = ans + ABS(j)
+ END IF
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4vec_lcm(n, v)
+ INTEGER(i4b), INTENT(in) :: n
+ INTEGER(i4b), INTENT(in) :: v(n)
+ INTEGER(i4b) :: i4vec_lcm
+ INTEGER(i4b) :: i
+ INTEGER(i4b) :: lcm
+ !
+ lcm = 1
+ DO i = 1, n
+ IF (v(i) == 0) THEN
+ lcm = 0
+ i4vec_lcm = lcm
+ RETURN
+ END IF
+ lcm = i4_lcm(lcm, v(i))
+ END DO
+ i4vec_lcm = lcm
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_lcm(i, j)
+ INTEGER(i4b), INTENT(in) :: i, j
+ INTEGER(I4B) :: i4_lcm
+ i4_lcm = ABS(i * (j / i4_gcd(i, j)))
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_gcd(i, j)
+ INTEGER(I4B), INTENT(IN) :: i, j
+ INTEGER(I4B) :: i4_gcd
+ !!
+ INTEGER(kind=4) p
+ INTEGER(kind=4) q
+ INTEGER(kind=4) r
+ !
+ i4_gcd = 1
+ !
+ ! Return immediately if either I or J is zero.
+ !
+ IF (i == 0) THEN
+ i4_gcd = MAX(1, ABS(j))
+ RETURN
+ ELSE IF (j == 0) THEN
+ i4_gcd = MAX(1, ABS(i))
+ RETURN
+ END IF
+ !
+ ! Set P to the larger of I and J, Q to the smaller.
+ ! This way, we can alter P and Q as we go.
+ !
+ p = MAX(ABS(i), ABS(j))
+ q = MIN(ABS(i), ABS(j))
+ !
+ ! Carry out the Euclidean algorithm.
+ !
+ DO
+ r = MOD(p, q)
+ IF (r == 0) THEN
+ EXIT
+ END IF
+ p = q
+ q = r
+ END DO
+ i4_gcd = q
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION r8_huge()
+ REAL(dfp) :: r8_huge
+ r8_huge = 1.0D+30
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
diff --git a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90 b/src/submodules/Line/src/ReferenceLine_Method@Methods.F90
similarity index 87%
rename from src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90
rename to src/submodules/Line/src/ReferenceLine_Method@Methods.F90
index 918998090..cb10e1d96 100644
--- a/src/submodules/Geometry/src/ReferenceLine_Method@Methods.F90
+++ b/src/submodules/Line/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
@@ -355,12 +372,21 @@
! GetFaceElemType_Line
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Line
+MODULE PROCEDURE GetFaceElemType_Line1
INTEGER(I4B) :: elemType0
elemType0 = Input(default=Line, option=elemType)
IF (PRESENT(faceElemType)) faceElemType(1:2) = Point1
IF (PRESENT(tFaceNodes)) tFaceNodes(1:2) = 1_I4B
-END PROCEDURE GetFaceElemType_Line
+END PROCEDURE GetFaceElemType_Line1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Line
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Line2
+faceElemType = Point1
+tFaceNodes = 1_I4B
+END PROCEDURE GetFaceElemType_Line2
!----------------------------------------------------------------------------
! GetFaceConnectivity_Triangle
diff --git a/src/submodules/MassMatrix/src/MM_1.inc b/src/submodules/MassMatrix/src/MM_1.inc
deleted file mode 100644
index aee971caa..000000000
--- a/src/submodules/MassMatrix/src/MM_1.inc
+++ /dev/null
@@ -1,52 +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
-!
-
-!----------------------------------------------------------------------------
-! MassMatrix
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE MM_1(ans, test, trial, rho, opt)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- !! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- !! scalar variable
- INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt
- !! ncopy
- !!
- !! Internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- INTEGER(I4B) :: ips
- !!
- !! main
- !!
- CALL reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
- CALL getInterpolation(obj=trial, interpol=realval, val=rho)
- realval = trial%js * trial%ws * trial%thickness * realval
- !!
- DO ips = 1, size(realval)
- ans = ans + realval(ips) * &
- & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- END DO
- !!
- if( present( opt ) ) CALL MakeDiagonalCopies(ans, opt)
- !!
- DEALLOCATE (realval)
-END SUBROUTINE MM_1
diff --git a/src/submodules/MassMatrix/src/MM_2a.inc b/src/submodules/MassMatrix/src/MM_2a.inc
deleted file mode 100644
index 0c31616c7..000000000
--- a/src/submodules/MassMatrix/src/MM_2a.inc
+++ /dev/null
@@ -1,58 +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
-
-!----------------------------------------------------------------------------
-! MassMatrix
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE MM_2a(ans, test, trial, rho, opt)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- !! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- !! vector variable
- INTEGER( I4B ), INTENT( IN ) :: opt
- !! 1
- !! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ii, ips
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
- !!
- CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1)
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ips = 1, SIZE(realval)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, ii, 1) = m4(:, :, ii, 1) &
- & + realval(ips) * vbar(ii, ips) * m2
- END DO
- END DO
- !!
- CALL Convert(From=m4, To=ans)
- !!
- DEALLOCATE (realval, m2, vbar, m4)
- !!
-END SUBROUTINE MM_2a
diff --git a/src/submodules/MassMatrix/src/MM_2b.inc b/src/submodules/MassMatrix/src/MM_2b.inc
deleted file mode 100644
index 3cbcb268e..000000000
--- a/src/submodules/MassMatrix/src/MM_2b.inc
+++ /dev/null
@@ -1,61 +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
-!
-
-!----------------------------------------------------------------------------
-! MassMatrix
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE MM_2b(ans, test, trial, rho, opt)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- !! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- !! vector variable
- INTEGER( I4B ), INTENT( IN ) :: opt
- !! 2
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ii, ips
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
- !!
- CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1))
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ips = 1, SIZE(realval)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, 1, ii) = m4(:, :, 1, ii) &
- & + realval(ips) * vbar(ii, ips) * m2
- END DO
- END DO
- !!
- CALL Convert(From=m4, To=ans)
- !!
- DEALLOCATE (realval, m2, vbar, m4)
- !!
-END SUBROUTINE MM_2b
diff --git a/src/submodules/MassMatrix/src/MM_2c.inc b/src/submodules/MassMatrix/src/MM_2c.inc
deleted file mode 100644
index edc9450fa..000000000
--- a/src/submodules/MassMatrix/src/MM_2c.inc
+++ /dev/null
@@ -1,59 +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
-
-!----------------------------------------------------------------------------
-! MassMatrix
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE MM_2c(ans, test, trial, rho, opt)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- !! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- !! vector variable
- INTEGER( I4B ), INTENT( IN ) :: opt
- !! 3
- !! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ips, ii
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
- !!
- CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
- & SIZE(vbar, 1), SIZE(vbar, 1))
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ips = 1, SIZE(vbar, 2)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, ii, ii) = m4(:, :, ii, ii) &
- & + realval(ips) * vbar(ii, ips) * m2
- END DO
- END DO
- !!
- CALL Convert(from=m4, to=ans)
- !!
- DEALLOCATE (realval, m2, vbar, m4)
- !!
-END SUBROUTINE MM_2c
diff --git a/src/submodules/MassMatrix/src/MM_2d.inc b/src/submodules/MassMatrix/src/MM_2d.inc
deleted file mode 100644
index 00474ec01..000000000
--- a/src/submodules/MassMatrix/src/MM_2d.inc
+++ /dev/null
@@ -1,61 +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
-!
-
-!----------------------------------------------------------------------------
-! MassMatrix
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE MM_2d(ans, test, trial, rho)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- !! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- !! vector variable
- !! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ips, ii, jj
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
- !!
- CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
- & SIZE(vbar, 1), SIZE(vbar, 1))
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ips = 1, SIZE(vbar, 2)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO jj = 1, SIZE(vbar, 1)
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, ii, jj) = m4(:, :, ii, jj) &
- & + realval(ips) * vbar(ii, ips) &
- & * vbar(jj, ips) * m2
- END DO
- END DO
- END DO
- !!
- CALL Convert(from=m4, to=ans)
- !!
- DEALLOCATE (realval, m2, vbar, m4)
- !!
-END SUBROUTINE MM_2d
diff --git a/src/submodules/MassMatrix/src/MM_3.inc b/src/submodules/MassMatrix/src/MM_3.inc
deleted file mode 100644
index b72f07d7f..000000000
--- a/src/submodules/MassMatrix/src/MM_3.inc
+++ /dev/null
@@ -1,62 +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
-!
-
-!----------------------------------------------------------------------------
-! MassMatrix
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE MM_3(ans, test, trial, rho, opt)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- !! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- !! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- !! matrix variable
- INTEGER( I4B ), OPTIONAL, INTENT( IN ) :: opt
- !! 4
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: kbar(:, :, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ii, jj, ips
- !!
- !! main
- !!
- CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
- CALL reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
- & SIZE(kbar, 1), SIZE(kbar, 2))
- !!
- realval = trial%js * trial%ws * trial%thickness
- !!
- DO ips = 1, SIZE(realval)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO jj = 1, SIZE(kbar, 2)
- DO ii = 1, SIZE(kbar, 1)
- m4(:, :, ii, jj) = m4(:, :, ii, jj) &
- & + realval(ips) * kbar(ii, jj, ips) * m2
- END DO
- END DO
- END DO
- !!
- CALL Convert(From=m4, To=ans)
- !!
- DEALLOCATE (realval, m2, kbar, m4)
-END SUBROUTINE MM_3
diff --git a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90 b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90
index 880619fef..cd9e3fe51 100644
--- a/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90
+++ b/src/submodules/MassMatrix/src/MassMatrix_Method@Methods.F90
@@ -16,7 +16,23 @@
!
SUBMODULE(MassMatrix_Method) Methods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
+USE ElemshapeData_Method, ONLY: GetInterpolation
+USE ElemshapeData_Method, ONLY: GetInterpolation_
+USE ProductUtility, ONLY: OuterProd_
+USE ProductUtility, ONLY: OuterProd
+USE ProductUtility, ONLY: OTimesTilda_
+USE ConvertUtility, ONLY: Convert
+USE ConvertUtility, ONLY: Convert_
+USE RealMatrix_Method, ONLY: MakeDiagonalCopies
+USE RealMatrix_Method, ONLY: MakeDiagonalCopies_
+USE EyeUtility, ONLY: Eye
+USE BaseType, ONLY: math => TypeMathOpt
+USE BaseType, ONLY: varopt => TypeFEVariableOpt
+USE InputUtility, ONLY: Input
+USE FEVariable_Method, ONLY: FEVariableSize => Size
+USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_
+
IMPLICIT NONE
CONTAINS
@@ -24,248 +40,352 @@
! MassMatrix
!----------------------------------------------------------------------------
-PURE SUBROUTINE MM_2a(ans, test, trial, rho)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- ! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- ! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- ! vector variable
- ! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ii, ips
-
- ! main
- CALL GetInterpolation(obj=trial, interpol=vbar, val=rho)
- CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1)
- realval = trial%js * trial%ws * trial%thickness
-
- DO ips = 1, SIZE(realval)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, ii, 1) = m4(:, :, ii, 1) &
- & + realval(ips) * vbar(ii, ips) * m2
- END DO
- END DO
-
- CALL Convert(From=m4, To=ans)
- DEALLOCATE (realval, m2, vbar, m4)
-END SUBROUTINE MM_2a
+MODULE PROCEDURE MassMatrix_1
+INTEGER(I4B) :: nrow, ncol, opt0
+
+opt0 = Input(option=opt, default=math%one_i)
+nrow = test%nns * opt0
+ncol = trial%nns * opt0
+CALL Reallocate(ans, nrow, ncol)
+CALL MassMatrix_(test=test, trial=trial, ans=ans, nrow=nrow, ncol=ncol, &
+ opt=opt0)
+END PROCEDURE MassMatrix_1
!----------------------------------------------------------------------------
-! MassMatrix
+!
!----------------------------------------------------------------------------
-PURE SUBROUTINE MM_2b(ans, test, trial, rho)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- ! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- ! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- ! vector variable
-
- ! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ii, ips
-
- ! main
- CALL GetInterpolation(obj=trial, interpol=vbar, val=rho)
- CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1))
- realval = trial%js * trial%ws * trial%thickness
-
- DO ips = 1, SIZE(realval)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, 1, ii) = m4(:, :, 1, ii) &
- & + realval(ips) * vbar(ii, ips) * m2
- END DO
- END DO
+MODULE PROCEDURE MassMatrix1_
+REAL(DFP) :: realval
+INTEGER(I4B) :: ii, jj, ips, opt0
+LOGICAL(LGT) :: isok
+
+nrow = test%nns
+ncol = trial%nns
+opt0 = Input(default=math%one_i, option=opt)
+ans(1:nrow * opt0, 1:ncol * opt0) = 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=math%one)
+END DO
- CALL Convert(From=m4, To=ans)
- DEALLOCATE (realval, m2, vbar, m4)
-END SUBROUTINE MM_2b
+isok = opt0 .GT. 1
+IF (isok) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt0, nrow=nrow, ncol=ncol)
+ nrow = opt0 * nrow
+ ncol = opt0 * ncol
+END IF
+END PROCEDURE MassMatrix1_
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
-PURE SUBROUTINE MM_2c(ans, test, trial, rho)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- ! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- ! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- ! vector variable
- ! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ips, ii
-
- ! main
- CALL GetInterpolation(obj=trial, interpol=vbar, val=rho)
- CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
- & SIZE(vbar, 1), SIZE(vbar, 1))
-
- realval = trial%js * trial%ws * trial%thickness
-
- DO ips = 1, SIZE(vbar, 2)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, ii, ii) = m4(:, :, ii, ii) &
- & + realval(ips) * vbar(ii, ips) * m2
- END DO
- END DO
-
- CALL Convert(from=m4, to=ans)
-
- DEALLOCATE (realval, m2, vbar, m4)
-END SUBROUTINE MM_2c
+MODULE PROCEDURE MassMatrix_2
+INTEGER(I4B) :: nrow, ncol, opt0
+
+opt0 = Input(option=opt, default=math%one_i)
+nrow = test%nns * opt0
+ncol = trial%nns * opt0
+CALL Reallocate(ans, nrow, ncol)
+CALL MassMatrix_(test=test, trial=trial, ans=ans, nrow=nrow, ncol=ncol, &
+ opt=opt0, rho=rho, rhorank=rhorank)
+END PROCEDURE MassMatrix_2
!----------------------------------------------------------------------------
-! MassMatrix
+!
!----------------------------------------------------------------------------
-PURE SUBROUTINE MM_2d(ans, test, trial, rho)
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(ElemshapeData_), INTENT(IN) :: test
- ! Shapedata for test function
- CLASS(ElemshapeData_), INTENT(IN) :: trial
- ! Shapedata for trial function
- CLASS(FEVariable_), INTENT(IN) :: rho
- ! vector variable
- ! Define internal variable
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: m2(:, :)
- REAL(DFP), ALLOCATABLE :: vbar(:, :)
- REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
- INTEGER(I4B) :: ips, ii, jj
-
- ! main
- CALL GetInterpolation(obj=trial, interpol=vbar, val=rho)
- CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
- & SIZE(vbar, 1), SIZE(vbar, 1))
-
- realval = trial%js * trial%ws * trial%thickness
-
- DO ips = 1, SIZE(vbar, 2)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO jj = 1, SIZE(vbar, 1)
- DO ii = 1, SIZE(vbar, 1)
- m4(:, :, ii, jj) = m4(:, :, ii, jj) &
- & + realval(ips) * vbar(ii, ips) &
- & * vbar(jj, ips) * m2
- END DO
- END DO
- END DO
+MODULE PROCEDURE MassMatrix2_
+INTEGER(I4B) :: ips, i1, i2, opt0
+REAL(DFP) :: realval, rhobar, T(0)
+LOGICAL(LGT) :: isok
+
+opt0 = Input(default=math%one_i, option=opt)
+nrow = test%nns
+ncol = trial%nns
+ans(1:nrow * opt0, 1:ncol * opt0) = math%zero
+
+DO ips = 1, test%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=rho, rank=rhorank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=rhobar)
- CALL Convert(from=m4, to=ans)
+ realval = rhobar * trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
- DEALLOCATE (realval, m2, vbar, m4)
-END SUBROUTINE MM_2d
+ CALL OuterProd_( &
+ a=test%N(1:nrow, ips), b=trial%N(1:ncol, ips), nrow=i1, ncol=i2, &
+ ans=ans, scale=realval, anscoeff=math%one)
+END DO
+
+isok = opt0 .GT. 1
+IF (isok) THEN
+ CALL MakeDiagonalCopies_(mat=ans, ncopy=opt0, nrow=nrow, ncol=ncol)
+ nrow = opt0 * nrow
+ ncol = opt0 * ncol
+END IF
+END PROCEDURE MassMatrix2_
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
-MODULE PROCEDURE MassMatrix_1
-! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-INTEGER(I4B) :: ips
-
-! main
-CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
-realval = trial%js * trial%ws * trial%thickness
+MODULE PROCEDURE MassMatrix_3
+! SELECT CASE (opt)
+! CASE (1)
+! CALL MM_3a(ans=ans, test=test, trial=trial, rho=rho)
+! CASE (2)
+! CALL MM_3b(ans=ans, test=test, trial=trial, rho=rho)
+! CASE (3)
+! CALL MM_3c(ans=ans, test=test, trial=trial, rho=rho)
+! CASE (4)
+! CALL MM_3d(ans=ans, test=test, trial=trial, rho=rho)
+! END SELECT
+END PROCEDURE MassMatrix_3
-DO ips = 1, SIZE(trial%N, 2)
- ans = ans + realval(ips) * &
- & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
-END DO
+!----------------------------------------------------------------------------
+! MassMatrix
+!----------------------------------------------------------------------------
-IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
-DEALLOCATE (realval)
-END PROCEDURE MassMatrix_1
+MODULE PROCEDURE MassMatrix3_
+! SELECT CASE (opt)
+! CASE (1)
+! CALL MM_3a(ans=ans, test=test, trial=trial, rho=rho)
+! CASE (2)
+! CALL MM_3b(ans=ans, test=test, trial=trial, rho=rho)
+! CASE (3)
+! CALL MM_3c(ans=ans, test=test, trial=trial, rho=rho)
+! CASE (4)
+! CALL MM_3d(ans=ans, test=test, trial=trial, rho=rho)
+! END SELECT
+END PROCEDURE MassMatrix3_
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
-MODULE PROCEDURE MassMatrix_2
-REAL(DFP), ALLOCATABLE :: realval(:)
-INTEGER(I4B) :: ips
+! PURE SUBROUTINE MM_3a(test, trial, rho, rhorank, ans, nrow, ncol)
+! CLASS(ElemshapeData_), INTENT(IN) :: test
+! ! Shapedata for test function
+! CLASS(ElemshapeData_), INTENT(IN) :: trial
+! ! Shapedata for trial function
+! CLASS(FEVariable_), INTENT(IN) :: rho
+! ! vector variable
+! TYPE(FEVariableVector_), INTENT(IN) :: rhorank
+! REAL(DFP), INTENT(INOUT) :: ans(:, :)
+! INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+!
+! ! Define internal variable
+! REAL(DFP), ALLOCATABLE :: realval(:)
+! REAL(DFP), ALLOCATABLE :: m2(:, :)
+! REAL(DFP), ALLOCATABLE :: vbar(:, :)
+! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
+! INTEGER(I4B) :: ii, ips
+!
+! ! main
+! CALL GetInterpolation(obj=trial, ans=vbar, val=rho)
+! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), SIZE(vbar, 1), 1)
+! realval = trial%js * trial%ws * trial%thickness
+!
+! DO ips = 1, SIZE(realval)
+! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
+! DO ii = 1, SIZE(vbar, 1)
+! m4(:, :, ii, 1) = m4(:, :, ii, 1) &
+! & + realval(ips) * vbar(ii, ips) * m2
+! END DO
+! END DO
+!
+! CALL Convert(From=m4, To=ans)
+! DEALLOCATE (realval, m2, vbar, m4)
+! END SUBROUTINE MM_3a
-! main
-CALL Reallocate(ans, SIZE(test%N, 1), SIZE(trial%N, 1))
-CALL GetInterpolation(obj=trial, interpol=realval, val=rho)
-realval = trial%js * trial%ws * trial%thickness * realval
+!----------------------------------------------------------------------------
+! MassMatrix
+!----------------------------------------------------------------------------
-DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * &
- & OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
-END DO
+! PURE SUBROUTINE MM_3b(ans, test, trial, rho)
+! REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+! CLASS(ElemshapeData_), INTENT(IN) :: test
+! ! Shapedata for test function
+! CLASS(ElemshapeData_), INTENT(IN) :: trial
+! ! Shapedata for trial function
+! CLASS(FEVariable_), INTENT(IN) :: rho
+! ! vector variable
+!
+! ! Define internal variable
+! REAL(DFP), ALLOCATABLE :: realval(:)
+! REAL(DFP), ALLOCATABLE :: m2(:, :)
+! REAL(DFP), ALLOCATABLE :: vbar(:, :)
+! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
+! INTEGER(I4B) :: ii, ips
+!
+! ! main
+! CALL GetInterpolation(obj=trial, ans=vbar, val=rho)
+! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), 1, SIZE(vbar, 1))
+! realval = trial%js * trial%ws * trial%thickness
+!
+! DO ips = 1, SIZE(realval)
+! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
+! DO ii = 1, SIZE(vbar, 1)
+! m4(:, :, 1, ii) = m4(:, :, 1, ii) &
+! & + realval(ips) * vbar(ii, ips) * m2
+! END DO
+! END DO
+!
+! CALL Convert(From=m4, To=ans)
+! DEALLOCATE (realval, m2, vbar, m4)
+! END SUBROUTINE MM_3b
-IF (PRESENT(opt)) CALL MakeDiagonalCopies(ans, opt)
-DEALLOCATE (realval)
-END PROCEDURE MassMatrix_2
+!----------------------------------------------------------------------------
+! MassMatrix
+!----------------------------------------------------------------------------
+
+! PURE SUBROUTINE MM_3c(ans, test, trial, rho)
+! REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+! CLASS(ElemshapeData_), INTENT(IN) :: test
+! ! Shapedata for test function
+! CLASS(ElemshapeData_), INTENT(IN) :: trial
+! ! Shapedata for trial function
+! CLASS(FEVariable_), INTENT(IN) :: rho
+! ! vector variable
+! ! Define internal variable
+! REAL(DFP), ALLOCATABLE :: realval(:)
+! REAL(DFP), ALLOCATABLE :: m2(:, :)
+! REAL(DFP), ALLOCATABLE :: vbar(:, :)
+! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
+! INTEGER(I4B) :: ips, ii
+!
+! ! main
+! CALL GetInterpolation(obj=trial, ans=vbar, val=rho)
+! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
+! & SIZE(vbar, 1), SIZE(vbar, 1))
+!
+! realval = trial%js * trial%ws * trial%thickness
+!
+! DO ips = 1, SIZE(vbar, 2)
+! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
+! DO ii = 1, SIZE(vbar, 1)
+! m4(:, :, ii, ii) = m4(:, :, ii, ii) &
+! & + realval(ips) * vbar(ii, ips) * m2
+! END DO
+! END DO
+!
+! CALL Convert(from=m4, to=ans)
+!
+! DEALLOCATE (realval, m2, vbar, m4)
+! END SUBROUTINE MM_3c
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
-MODULE PROCEDURE MassMatrix_3
-SELECT CASE (opt)
-CASE (1)
- CALL MM_2a(ans=ans, test=test, trial=trial, rho=rho)
-CASE (2)
- CALL MM_2b(ans=ans, test=test, trial=trial, rho=rho)
-CASE (3)
- CALL MM_2c(ans=ans, test=test, trial=trial, rho=rho)
-CASE (4)
- CALL MM_2d(ans=ans, test=test, trial=trial, rho=rho)
-END SELECT
-END PROCEDURE MassMatrix_3
+! PURE SUBROUTINE MM_3d(ans, test, trial, rho)
+! REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
+! CLASS(ElemshapeData_), INTENT(IN) :: test
+! ! Shapedata for test function
+! CLASS(ElemshapeData_), INTENT(IN) :: trial
+! ! Shapedata for trial function
+! CLASS(FEVariable_), INTENT(IN) :: rho
+! ! vector variable
+! ! Define internal variable
+! REAL(DFP), ALLOCATABLE :: realval(:)
+! REAL(DFP), ALLOCATABLE :: m2(:, :)
+! REAL(DFP), ALLOCATABLE :: vbar(:, :)
+! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
+! INTEGER(I4B) :: ips, ii, jj
+!
+! ! main
+! CALL GetInterpolation(obj=trial, ans=vbar, val=rho)
+! CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
+! & SIZE(vbar, 1), SIZE(vbar, 1))
+!
+! realval = trial%js * trial%ws * trial%thickness
+!
+! DO ips = 1, SIZE(vbar, 2)
+! m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
+! DO jj = 1, SIZE(vbar, 1)
+! DO ii = 1, SIZE(vbar, 1)
+! m4(:, :, ii, jj) = m4(:, :, ii, jj) &
+! & + realval(ips) * vbar(ii, ips) &
+! & * vbar(jj, ips) * m2
+! END DO
+! END DO
+! END DO
+!
+! CALL Convert(from=m4, to=ans)
+!
+! DEALLOCATE (realval, m2, vbar, m4)
+! END SUBROUTINE MM_3d
!----------------------------------------------------------------------------
! MassMatrix
!----------------------------------------------------------------------------
MODULE PROCEDURE MassMatrix_4
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: m2(:, :)
-REAL(DFP), ALLOCATABLE :: kbar(:, :, :)
+INTEGER(I4B) :: rhobar_i, rhobar_j, nns1, nns2
REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
-INTEGER(I4B) :: ii, jj, ips
+
+rhobar_i = FEVariableSize(obj=rho, dim=1)
+rhobar_j = FEVariableSize(obj=rho, dim=2)
+nns1 = test%nns
+nns2 = trial%nns
+
+CALL Reallocate(m4, nns1, nns2, rhobar_i, rhobar_j)
+CALL Reallocate(ans, nns1 * rhobar_i, nns2 * rhobar_j)
+
+CALL MassMatrix_(test=test, trial=trial, rho=rho, rhorank=rhorank, &
+ ans=ans, nrow=nns1, ncol=nns2, m4=m4)
+! nns1 and nns2 are dummary values here as we dont use them
+
+DEALLOCATE (m4)
+END PROCEDURE MassMatrix_4
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix4_
+INTEGER(I4B) :: ips, rhobar_i, rhobar_j, nns1, nns2
+INTEGER(I4B) :: i1, i2, i3, i4
+REAL(DFP) :: realval, T(0), &
+ rhobar(varopt%defaultMatrixSize, varopt%defaultMatrixSize)
! main
-CALL GetInterpolation(obj=trial, interpol=kbar, val=rho)
-CALL Reallocate(m4, SIZE(test%N, 1), SIZE(trial%N, 1), &
- & SIZE(kbar, 1), SIZE(kbar, 2))
-realval = trial%js * trial%ws * trial%thickness
+rhobar_i = FEVariableSize(obj=rho, dim=1)
+rhobar_j = FEVariableSize(obj=rho, dim=2)
+nns1 = test%nns
+nns2 = trial%nns
-DO ips = 1, SIZE(realval)
- m2 = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
- DO jj = 1, SIZE(kbar, 2)
- DO ii = 1, SIZE(kbar, 1)
- m4(:, :, ii, jj) = m4(:, :, ii, jj) &
- & + realval(ips) * kbar(ii, jj, ips) * m2
- END DO
- END DO
+! nrow = nns1 * rhobar_i
+! ncol = nns2 * rhobar_j
+
+m4(1:nns1, 1:nns2, 1:rhobar_i, 1:rhobar_j) = math%zero
+
+DO ips = 1, test%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=rho, rank=rhorank, N=test%N, nns=test%nns, spaceIndx=ips, &
+ timeIndx=math%one_i, T=T, nnt=math%zero_i, scale=math%one, &
+ addContribution=math%no, ans=rhobar, nrow=i1, ncol=i2)
+
+ realval = trial%js(ips) * trial%ws(ips) * trial%thickness(ips)
+
+ CALL OuterProd_(a=test%N(1:nns1, ips), b=trial%N(1:nns2, ips), &
+ c=rhobar(1:rhobar_i, 1:rhobar_j), &
+ scale=realval, anscoeff=math%one, &
+ ans=m4, dim1=i1, dim2=i2, dim3=i3, dim4=i4)
END DO
-CALL Convert(From=m4, To=ans)
-DEALLOCATE (realval, m2, kbar, m4)
-END PROCEDURE MassMatrix_4
+CALL Convert_(from=m4(1:nns1, 1:nns2, 1:rhobar_i, 1:rhobar_j), &
+ to=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE MassMatrix4_
!----------------------------------------------------------------------------
! MassMatrix
@@ -283,16 +403,16 @@ END SUBROUTINE MM_2d
INTEGER(I4B) :: ii, jj, ips, nsd, nns
! main
-CALL GetInterpolation(obj=trial, interpol=lambdaBar, val=lambda)
-CALL GetInterpolation(obj=trial, interpol=muBar, val=mu)
-CALL GetInterpolation(obj=trial, interpol=rhoBar, val=rho)
+CALL GetInterpolation(obj=trial, ans=lambdaBar, val=lambda)
+CALL GetInterpolation(obj=trial, ans=muBar, val=mu)
+CALL GetInterpolation(obj=trial, ans=rhoBar, val=rho)
ALLOCATE (acoeff(SIZE(lambdaBar, 1)), bcoeff(SIZE(lambdaBar, 1)))
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))
@@ -319,6 +439,187 @@ END SUBROUTINE MM_2d
& eyemat, nij)
END PROCEDURE MassMatrix_5
+!----------------------------------------------------------------------------
+! MassMatrix_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix5_
+! REAL(DFP), ALLOCATABLE :: realval(:)
+! REAL(DFP), ALLOCATABLE :: m2(:, :), eyemat(:, :), nij(:, :)
+! REAL(DFP), ALLOCATABLE :: lambdaBar(:)
+! REAL(DFP), ALLOCATABLE :: muBar(:)
+! REAL(DFP), ALLOCATABLE :: rhoBar(:)
+! REAL(DFP), ALLOCATABLE :: acoeff(:)
+! REAL(DFP), ALLOCATABLE :: bcoeff(:)
+! REAL(DFP), ALLOCATABLE :: m4(:, :, :, :)
+! INTEGER(I4B) :: ii, jj, ips, nsd, nns
+! REAL(DFP) :: lambdaBar, muBar, rhoBar, acoeff, bcoeff
+!
+! ! main
+! ALLOCATE (acoeff(SIZE(lambdaBar, 1)), bcoeff(SIZE(lambdaBar, 1)))
+!
+! bcoeff = SQRT(rhoBar * muBar)
+! acoeff = SQRT(rhoBar * (lambdaBar + 2.0_DFP * muBar)) - bcoeff
+!
+! nsd = trial%nsd
+! eyemat = Eye(nsd, 1.0_DFP)
+! nns = SIZE(test%N, 1)
+! ALLOCATE (m4(nns, nns, nsd, nsd))
+!
+! realval = trial%js * trial%ws * trial%thickness
+!
+! DO ips = 1, SIZE(realval)
+! m2 = OUTERPROD(a=test%normal(:, ips), b=trial%normal(:, ips))
+! nij = OUTERPROD(a=test%N(:, ips), b=trial%N(:, ips))
+!
+! DO jj = 1, nsd
+! DO ii = 1, nsd
+!
+! m4(:, :, ii, jj) = m4(:, :, ii, jj) + realval(ips) * &
+! & (acoeff(ips) * m2(ii, jj) + bcoeff(ips) * eyemat(ii, jj)) * nij
+!
+! END DO
+! END DO
+! END DO
+!
+! CALL Convert(From=m4, To=ans)
+!
+! DEALLOCATE (realval, m2, lambdaBar, muBar, rhoBar, acoeff, bcoeff, m4, &
+! & eyemat, nij)
+END PROCEDURE MassMatrix5_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix6_
+REAL(DFP) :: realval
+INTEGER(I4B) :: ii, jj, ips
+
+nrow = nns1
+ncol = nns2
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ips = 1, nips
+ realval = js(ips) * ws(ips) * thickness(ips)
+
+ CALL OuterProd_( &
+ a=N(1:nrow, ips), b=M(1:ncol, ips), nrow=ii, ncol=jj, &
+ ans=ans, scale=realval, anscoeff=math%one)
+END DO
+END PROCEDURE MassMatrix6_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix7_
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: a, b, c, d, mynns1, mynns2
+
+IF (.NOT. skipVertices) THEN
+ CALL MassMatrix_( &
+ N=N, M=M, js=js, ws=ws, thickness=thickness, &
+ nips=nips, nns1=nns1, nns2=nns2, ans=ans, nrow=nrow, ncol=ncol)
+ RETURN
+END IF
+
+isok = (nns1 .GT. tVertices) .AND. (nns2 .GT. tVertices)
+IF (.NOT. isok) THEN
+ nrow = 0
+ ncol = 0
+ RETURN
+END IF
+
+a = tVertices + 1
+b = nns1
+c = tVertices + 1
+d = nns2
+mynns1 = nns1 - tVertices
+mynns2 = nns2 - tVertices
+
+CALL MassMatrix_( &
+ N=N(a:b, :), M=M(c:d, :), js=js, ws=ws, thickness=thickness, &
+ nips=nips, nns1=mynns1, nns2=mynns2, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE MassMatrix7_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix8_
+INTEGER(I4B) :: ips, ipt
+REAL(DFP) :: realval
+
+nrow = nnt1 * nns1
+ncol = nnt2 * nns2
+ans(1:nrow, 1:ncol) = 0.0
+
+DO ipt = 1, nipt
+ DO ips = 1, nips
+
+ realval = ws(ips) * js(ips) * spaceThickness(ips) * &
+ wt(ipt) * jt(ipt) * timeThickness(ipt)
+
+ CALL OTimesTilda_(a=timeN(1:nnt1, ipt), b=timeM(1:nnt2, ipt), &
+ c=spaceN(1:nns1, ips), d=spaceM(1:nns2, ips), ans=ans, &
+ nrow=nrow, ncol=ncol, anscoeff=math%one, scale=realval)
+
+ END DO
+END DO
+END PROCEDURE MassMatrix8_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MassMatrix9_
+LOGICAL(LGT) :: donothing
+INTEGER(I4B) :: a, b, c, d, e, f, g, h, mynns1, mynns2, mynnt1, mynnt2
+
+IF (.NOT. skipVertices) THEN
+ CALL MassMatrix_( &
+ spaceN=spaceN, spaceM=spaceM, timeN=timeN, timeM=timeM, js=js, ws=ws, &
+ jt=jt, wt=wt, spaceThickness=spaceThickness, &
+ timeThickness=timeThickness, nips=nips, nns1=nns1, nns2=nns2, &
+ nipt=nipt, nnt1=nnt1, nnt2=nnt2, ans=ans, nrow=nrow, ncol=ncol)
+ RETURN
+END IF
+
+donothing = (nns1 .LE. tSpaceVertices) &
+ .OR. (nns2 .LE. tSpaceVertices) &
+ .OR. (nnt1 .LE. tTimeVertices) &
+ .OR. (nnt2 .LE. tTimeVertices)
+
+IF (donothing) THEN
+ nrow = 0
+ ncol = 0
+ RETURN
+END IF
+
+a = tSpaceVertices + 1
+b = nns1
+c = tSpaceVertices + 1
+d = nns2
+e = tTimeVertices + 1
+f = nnt1
+g = tTimeVertices + 1
+h = nnt2
+
+mynns1 = nns1 - tSpaceVertices
+mynns2 = nns2 - tSpaceVertices
+mynnt1 = nnt1 - tTimeVertices
+mynnt2 = nnt2 - tTimeVertices
+
+CALL MassMatrix_( &
+ spaceN=spaceN(a:b, :), spaceM=spaceM(c:d, :), timeN=timeN(e:f, :), &
+ timeM=timeM(g:h, :), js=js, ws=ws, jt=jt, wt=wt, &
+ spaceThickness=spaceThickness, timeThickness=timeThickness, nips=nips, &
+ nns1=mynns1, nns2=mynns2, nipt=nipt, nnt1=mynnt1, nnt2=mynnt2, ans=ans, &
+ nrow=nrow, ncol=ncol)
+
+END PROCEDURE MassMatrix9_
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/Point/CMakeLists.txt b/src/submodules/Point/CMakeLists.txt
new file mode 100644
index 000000000..8f444e95d
--- /dev/null
+++ b/src/submodules/Point/CMakeLists.txt
@@ -0,0 +1,20 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferencePoint_Method@Methods.F90)
diff --git a/src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90 b/src/submodules/Point/src/ReferencePoint_Method@Methods.F90
similarity index 100%
rename from src/submodules/Geometry/src/ReferencePoint_Method@Methods.F90
rename to src/submodules/Point/src/ReferencePoint_Method@Methods.F90
diff --git a/src/submodules/Polynomial/CMakeLists.txt b/src/submodules/Polynomial/CMakeLists.txt
index 90b4a65e5..c1588532b 100644
--- a/src/submodules/Polynomial/CMakeLists.txt
+++ b/src/submodules/Polynomial/CMakeLists.txt
@@ -18,21 +18,9 @@
set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
target_sources(
${PROJECT_NAME}
- PRIVATE ${src_path}/LineInterpolationUtility@Methods.F90
- ${src_path}/QuadraturePoint_Triangle_Solin.F90
- ${src_path}/QuadraturePoint_Tetrahedron_Solin.F90
- ${src_path}/TriangleInterpolationUtility@Methods.F90
- ${src_path}/TriangleInterpolationUtility@QuadratureMethods.F90
- ${src_path}/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
- ${src_path}/TriangleInterpolationUtility@LagrangeBasisMethods.F90
- ${src_path}/TriangleInterpolationUtility@OrthogonalBasisMethods.F90
- ${src_path}/QuadrangleInterpolationUtility@Methods.F90
- ${src_path}/TetrahedronInterpolationUtility@Methods.F90
- ${src_path}/HexahedronInterpolationUtility@Methods.F90
- ${src_path}/PrismInterpolationUtility@Methods.F90
- ${src_path}/PyramidInterpolationUtility@Methods.F90
- ${src_path}/InterpolationUtility@Methods.F90
+ PRIVATE ${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/HierarchicalPolynomialUtility@Methods.F90 b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90
new file mode 100644
index 000000000..4a9722da2
--- /dev/null
+++ b/src/submodules/Polynomial/src/HierarchicalPolynomialUtility@Methods.F90
@@ -0,0 +1,602 @@
+! 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
+LOGICAL(LGT) :: isok
+
+ans = 0
+
+ii = HierarchicalVertexDOF(elemType=elemType)
+ans = ans + ii
+
+isok = PRESENT(cellOrder)
+IF (isok) THEN
+ ii = HierarchicalCellDOF(elemType=elemType, order=cellOrder)
+ ans = ans + ii
+END IF
+
+isok = PRESENT(faceOrder)
+IF (isok) THEN
+ ii = HierarchicalFaceDOF(elemType=elemType, order=faceOrder)
+ ans = ans + ii
+END IF
+
+isok = PRESENT(edgeOrder)
+IF (isok) 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..c49b17cb7 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
@@ -287,11 +249,21 @@
! LagrangeVandermonde_
!----------------------------------------------------------------------------
-MODULE PROCEDURE LagrangeVandermonde_
+MODULE PROCEDURE LagrangeVandermonde1_
INTEGER(I4B), ALLOCATABLE :: degree(:, :)
+degree = LagrangeDegree(order=order, elemType=elemType)
+CALL LagrangeVandermonde2_(xij=xij, degree=degree, ans=ans, nrow=nrow, &
+ ncol=ncol)
+IF (ALLOCATED(degree)) DEALLOCATE (degree)
+END PROCEDURE LagrangeVandermonde1_
+
+!----------------------------------------------------------------------------
+! LagrangeVandermonde_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeVandermonde2_
INTEGER(I4B) :: jj, nsd, ii
-degree = LagrangeDegree(order=order, elemType=elemType)
nrow = SIZE(xij, 2)
nsd = SIZE(degree, 2)
ncol = SIZE(degree, 1)
@@ -318,63 +290,128 @@
END SELECT
-IF (ALLOCATED(degree)) DEALLOCATE (degree)
-END PROCEDURE LagrangeVandermonde_
+END PROCEDURE LagrangeVandermonde2_
!----------------------------------------------------------------------------
! EquidistancePoint
!----------------------------------------------------------------------------
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 +419,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 +486,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 +537,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 +583,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 +632,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 +716,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 +736,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
deleted file mode 100644
index ba2d7102b..000000000
--- a/src/submodules/Polynomial/src/LineInterpolationUtility@Methods.F90
+++ /dev/null
@@ -1,1404 +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(LineInterpolationUtility) Methods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! RefElemDomain_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE RefElemDomain_Line
-ans = "BIUNIT"
-END PROCEDURE RefElemDomain_Line
-
-!----------------------------------------------------------------------------
-! QuadratureNumber_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE QuadratureNumber_Line
-SELECT CASE (quadType)
-CASE (GaussLegendre, GaussChebyshev, GaussJacobi, GaussUltraspherical)
- ans = 1_I4B + INT(order / 2, kind=I4B)
-CASE DEFAULT
- ans = 2_I4B + INT(order / 2, kind=I4B)
-END SELECT
-END PROCEDURE QuadratureNumber_Line
-
-!----------------------------------------------------------------------------
-! ToVEFC_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE ToVEFC_Line
-REAL(DFP) :: t1
-INTEGER(I4B) :: np
-np = SIZE(pt)
-t1 = pt(np)
-IF (np .GT. 2) THEN
- pt(3:np) = pt(2:np - 1)
- pt(2) = t1
-END IF
-END PROCEDURE ToVEFC_Line
-
-!----------------------------------------------------------------------------
-! LagrangeDegree_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDegree_Line
-INTEGER(I4B) :: ii, n
-n = LagrangeDOF_Line(order=order)
-ALLOCATE (ans(n, 1))
-DO ii = 1, n
- ans(ii, 1) = ii - 1
-END DO
-END PROCEDURE LagrangeDegree_Line
-
-!----------------------------------------------------------------------------
-! LagrangeDOF_Point
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDOF_Point
-ans = 1_I4B
-END PROCEDURE LagrangeDOF_Point
-
-!----------------------------------------------------------------------------
-! LagrangeDOF_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDOF_Line
-ans = order + 1
-END PROCEDURE LagrangeDOF_Line
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeInDOF_Line
-ans = order - 1_I4B
-END PROCEDURE LagrangeInDOF_Line
-
-!----------------------------------------------------------------------------
-! GetTotalDOF_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE GetTotalDOF_Line
-ans = order + 1
-END PROCEDURE GetTotalDOF_Line
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE GetTotalInDOF_Line
-ans = order - 1_I4B
-END PROCEDURE GetTotalInDOF_Line
-
-!----------------------------------------------------------------------------
-! EquidistanceInPoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EquidistanceInPoint_Line1
-INTEGER(I4B) :: n, ii
-REAL(DFP) :: avar
-IF (order .LE. 1_I4B) THEN
- ALLOCATE (ans(0))
- RETURN
-END IF
-n = LagrangeInDOF_Line(order=order)
-ALLOCATE (ans(n))
-avar = (xij(2) - xij(1)) / order
-DO ii = 1, n
- ans(ii) = xij(1) + ii * avar
-END DO
-END PROCEDURE EquidistanceInPoint_Line1
-
-!----------------------------------------------------------------------------
-! EquidistanceInPoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EquidistanceInPoint_Line2
-INTEGER(I4B) :: n, ii, nsd
-REAL(DFP) :: x0(3, 2)
-REAL(DFP) :: avar(3)
-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)
-ELSE
- nsd = 1_I4B
- x0(1:nsd, 1) = [-1.0]
- x0(1:nsd, 2) = [1.0]
-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
-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
-END PROCEDURE EquidistancePoint_Line1
-
-!----------------------------------------------------------------------------
-! EquidistancePoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EquidistancePoint_Line2
-INTEGER(I4B) :: nsd
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- CALL Reallocate(ans, nsd, order + 1)
- IF (order .EQ. 0_I4B) THEN
- ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2))
- RETURN
- END IF
- ans(1:nsd, 1) = xij(1:nsd, 1)
- ans(1:nsd, 2) = xij(1:nsd, 2)
-ELSE
- nsd = 1_I4B
- CALL Reallocate(ans, nsd, order + 1)
- IF (order .EQ. 0_I4B) THEN
- ans(1:nsd, 1) = 0.0_DFP
- RETURN
- END IF
- ans(1:nsd, 1) = [-1.0]
- 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
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE InterpolationPoint_Line1
-CHARACTER(20) :: astr
-INTEGER(I4B) :: nsd, ii
-REAL(DFP) :: temp(order + 1), t1
-
-IF (order .EQ. 0_I4B) THEN
- IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- CALL Reallocate(ans, nsd, 1)
- ans(1:nsd, 1) = 0.5_DFP * (xij(1:nsd, 1) + xij(1:nsd, 2))
- ELSE
- CALL Reallocate(ans, 1, 1)
- ans = 0.0_DFP
- END IF
- RETURN
-END IF
-
-astr = TRIM(UpperCase(layout))
-
-SELECT CASE (ipType)
-
-CASE (Equidistance)
- ans = EquidistancePoint_Line(xij=xij, order=order)
- IF (astr .EQ. "INCREASING") THEN
- DO ii = 1, SIZE(ans, 1)
- ans(ii, :) = SORT(ans(ii, :))
- END DO
- END IF
- RETURN
-CASE (GaussLegendre)
- CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=Gauss)
-CASE (GaussLegendreLobatto)
- CALL LegendreQuadrature(n=order + 1, pt=temp, quadType=GaussLobatto)
- IF (layout .EQ. "VEFC") THEN
- t1 = temp(order + 1)
- IF (order .GE. 2) THEN
- temp(3:) = temp(2:order)
- END IF
- temp(2) = t1
- END IF
-
-CASE (GaussChebyshev)
- CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=Gauss)
-
-CASE (GaussChebyshevLobatto)
- CALL Chebyshev1Quadrature(n=order + 1, pt=temp, quadType=GaussLobatto)
- IF (layout .EQ. "VEFC") THEN
- t1 = temp(order + 1)
- IF (order .GE. 2) THEN
- temp(3:) = temp(2:order)
- END IF
- temp(2) = t1
- END IF
-
-CASE (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
-
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & 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=GaussJacobi", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
-
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=GaussLobatto, &
- & alpha=alpha, &
- & beta=beta)
-
- 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 (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
-
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=Gauss, &
- & lambda=lambda)
-
-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
-
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=temp, &
- & quadType=GaussLobatto, &
- & lambda=lambda)
-
- IF (layout .EQ. "VEFC") THEN
- t1 = temp(order + 1)
- IF (order .GE. 2) THEN
- temp(3:) = temp(2:order)
- END IF
- temp(2) = t1
- END IF
-
-CASE DEFAULT
- CALL ErrorMsg(&
- & msg="Unknown iptype", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
-END SELECT
-
-IF (ipType .NE. Equidistance) THEN
- IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
- CALL Reallocate(ans, nsd, order + 1)
- ans = FromBiunitLine2Segment(xin=temp, x1=xij(:, 1), &
- & x2=xij(:, 2))
- ELSE
- CALL Reallocate(ans, 1, order + 1)
- ans(1, :) = temp
- END IF
-END IF
-END PROCEDURE InterpolationPoint_Line1
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE InterpolationPoint_Line2
-CHARACTER(20) :: astr
-REAL(DFP) :: t1
-
-IF (order .EQ. 0_I4B) THEN
- ans = [0.5_DFP * (xij(1) + xij(2))]
- RETURN
-END IF
-
-CALL Reallocate(ans, order + 1)
-astr = TRIM(UpperCase(layout))
-
-SELECT CASE (ipType)
-CASE (Equidistance)
- ans = EquidistancePoint_Line(xij=xij, order=order)
- IF (astr .EQ. "INCREASING") ans = SORT(ans)
- RETURN
-
-CASE (GaussLegendre)
- CALL LegendreQuadrature(n=order + 1, pt=ans, quadType=Gauss)
-
-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
-
-CASE (GaussChebyshev)
- CALL Chebyshev1Quadrature(n=order + 1, pt=ans, quadType=Gauss)
-
-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 (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
-
- 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
-
- CALL JacobiQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=GaussLobatto, &
- & alpha=alpha, &
- & beta=beta)
-
- 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 (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
-
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=Gauss, &
- & lambda=lambda)
-
-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
-
- CALL UltrasphericalQuadrature( &
- & n=order + 1, &
- & pt=ans, &
- & quadType=GaussLobatto, &
- & lambda=lambda)
-
- IF (layout .EQ. "VEFC") THEN
- t1 = ans(order + 1)
- IF (order .GE. 2) THEN
- ans(3:) = ans(2:order)
- END IF
- ans(2) = t1
- END IF
-
-CASE DEFAULT
- CALL ErrorMsg(&
- & msg="Unknown iptype", &
- & file=__FILE__, &
- & routine="InterpolationPoint_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
-END SELECT
-
-IF (ipType .NE. Equidistance) THEN
- ans = FromBiunitLine2Segment(xin=ans, x1=xij(1), x2=xij(2))
-END IF
-END PROCEDURE InterpolationPoint_Line2
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Line1
-REAL(DFP) :: v(SIZE(xij, 2), SIZE(xij, 2))
-INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
-INTEGER(I4B) :: info
-v = LagrangeVandermonde(order=order, xij=xij, elemType=Line2)
-CALL getLU(A=v, IPIV=ipiv, info=info)
-ans = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Line1
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Line2
-REAL(DFP) :: vtemp(SIZE(v, 1), SIZE(v, 2))
-INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv
-INTEGER(I4B) :: info
-vtemp = v; ipiv = 0
-CALL getLU(A=vtemp, IPIV=ipiv, info=info)
-ans = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Line2
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Line3
-INTEGER(I4B) :: info
-ans = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Line3
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Line4
-ans = LagrangeVandermonde(order=order, xij=xij, elemType=Line2)
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Line4
-
-!----------------------------------------------------------------------------
-! 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
-END PROCEDURE LagrangeCoeff_Line5
-
-!----------------------------------------------------------------------------
-! 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
-
-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)
- RETURN
-END IF
-
-orthopol0 = input(default=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)
- END IF
- coeff0 = TRANSPOSE(coeff)
-ELSE
- coeff0 = TRANSPOSE(LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & ))
-END IF
-
-SELECT CASE (orthopol0)
-CASE (Monomial)
- 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, :))
-
-END PROCEDURE LagrangeEvalAll_Line1
-
-!----------------------------------------------------------------------------
-! LagrangeEvalAll_Line
-!----------------------------------------------------------------------------
-
-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
-
-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)
- RETURN
-END IF
-
-orthopol0 = Input(default=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)
- END IF
- coeff0 = coeff
-ELSE
- coeff0 = LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
-END IF
-
-SELECT CASE (orthopol0)
-CASE (Monomial)
- 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)
-
-END PROCEDURE LagrangeEvalAll_Line2
-
-!----------------------------------------------------------------------------
-! EvalAll_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE BasisEvalAll_Line1
-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="BasisEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END IF
-
-basisType0 = input(default=Monomial, option=basisType)
-SELECT CASE (basisType0)
-CASE (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
- 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)
- RETURN
- 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="BasisEvalAll_Line1", &
- & 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])
-END SELECT
-
-END PROCEDURE BasisEvalAll_Line1
-
-!----------------------------------------------------------------------------
-! BasisGradientEvalAll_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE BasisGradientEvalAll_Line1
-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_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END IF
-
-basisType0 = input(default=Monomial, option=basisType)
-SELECT CASE (basisType0)
-CASE (Monomial)
- ans(1) = 0.0_DFP
- DO ii = 1, order
- ans(ii + 1) = REAL(ii, dfp) * x**(ii - 1)
- END DO
-CASE DEFAULT
-
- 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="BasisGradientEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
- 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="BasisGradientEvalAll_Line1", &
- & 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])
-END SELECT
-
-END PROCEDURE BasisGradientEvalAll_Line1
-
-!----------------------------------------------------------------------------
-! BasisEvalAll_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE BasisEvalAll_Line2
-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="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END IF
-
-basisType0 = input(default=Monomial, option=basisType)
-SELECT CASE (basisType0)
-CASE (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
- 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)
- RETURN
- 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="BasisEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
- END IF
- END IF
-
- ans = EvalAllOrthopol(&
- & n=order, &
- & x=x, &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END SELECT
-
-END PROCEDURE BasisEvalAll_Line2
-
-!----------------------------------------------------------------------------
-! BasisGradientEvalAll_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE BasisGradientEvalAll_Line2
-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)
- RETURN
-END IF
-
-basisType0 = input(default=Monomial, option=basisType)
-SELECT CASE (basisType0)
-CASE (Monomial)
- ans(:, 1) = 0.0_DFP
- DO ii = 1, order
- ans(:, ii + 1) = REAL(ii, dfp) * x**(ii - 1)
- END DO
-CASE DEFAULT
-
- 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="BasisGradientEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
- 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="BasisGradientEvalAll_Line2", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
- END IF
- END IF
-
- ans = GradientEvalAllOrthopol(&
- & n=order, &
- & x=x, &
- & orthopol=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END SELECT
-
-END PROCEDURE BasisGradientEvalAll_Line2
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE QuadraturePoint_Line1
-INTEGER(I4B) :: nips(1)
-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)
-END PROCEDURE QuadraturePoint_Line1
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE QuadraturePoint_Line2
-ans = QuadraturePoint_Line1(&
- & order=order, &
- & quadType=quadType, &
- & layout=layout, &
- & xij=RESHAPE(xij, [1, 2]), &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END PROCEDURE QuadraturePoint_Line2
-
-!----------------------------------------------------------------------------
-! 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)
-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
-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)
- 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)
- END IF
- RETURN
-END IF
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 1
-END IF
-
-astr = TRIM(UpperCase(layout))
-np = nips(1)
-CALL Reallocate(ans, nsd + 1_I4B, np)
-changeLayout = .FALSE.
-
-SELECT CASE (quadType)
-
-CASE (GaussLegendre)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=Gauss)
-
-CASE (GaussLegendreRadauLeft)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft)
-
-CASE (GaussLegendreRadauRight)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight)
-
-CASE (GaussLegendreLobatto)
- CALL LegendreQuadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
-
-CASE (GaussChebyshev)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=Gauss)
-
-CASE (GaussChebyshevRadauLeft)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauLeft)
-
-CASE (GaussChebyshevRadauRight)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussRadauRight)
-
-CASE (GaussChebyshevLobatto)
- CALL Chebyshev1Quadrature(n=np, pt=pt, wt=wt, quadType=GaussLobatto)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
-
-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 (GaussUltrasphericalRadauLeft)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussRadauLeft, &
- & lambda=lambda)
-
-CASE (GaussUltrasphericalRadauRight)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussRadauRight, &
- & lambda=lambda)
-
-CASE (GaussUltrasphericalLobatto)
- CALL UltrasphericalQuadrature( &
- & n=np, &
- & pt=pt, &
- & wt=wt, &
- & quadType=GaussLobatto, &
- & lambda=lambda)
- IF (layout .EQ. "VEFC") changeLayout = .TRUE.
-
-CASE DEFAULT
- CALL ErrorMsg(&
- & msg="Unknown iptype", &
- & file=__FILE__, &
- & routine="QuadraturePoint_Line3", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END SELECT
-
-IF (changeLayout) THEN
- CALL ToVEFC_Line(pt)
- CALL ToVEFC_Line(wt)
-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
-END IF
-END PROCEDURE QuadraturePoint_Line3
-
-!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeGradientEvalAll_Line1
-LOGICAL(LGT) :: firstCall0
-REAL(DFP) :: coeff0(order + 1, order + 1), xx(SIZE(x, 2), order + 1)
-INTEGER(I4B) :: ii, orthopol0
-
-orthopol0 = input(default=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)
- END IF
- coeff0 = coeff
-ELSE
- coeff0 = LagrangeCoeff_Line(&
- & order=order, &
- & xij=xij, &
- & basisType=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
-END IF
-
-SELECT CASE (orthopol0)
-CASE (Monomial)
-
- IF (SIZE(xij, 2) .NE. order + 1) THEN
- CALL Errormsg(&
- & msg="size(xij, 2) is not same as order+1", &
- & file=__FILE__, &
- & routine="LagrangeGradientEvalAll_Line1", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
- END IF
-
- DO ii = 0, order
- xx(:, ii + 1) = REAL(ii, kind=DFP) * x(1, :)**(MAX(ii - 1_I4B, 0_I4B))
- END DO
-
-CASE DEFAULT
- xx = GradientEvalAllOrthopol(&
- & n=order, &
- & x=x(1, :), &
- & orthopol=orthopol0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-END SELECT
-
-ans(:, :, 1) = MATMUL(xx, coeff0)
-
-END PROCEDURE LagrangeGradientEvalAll_Line1
-
-!----------------------------------------------------------------------------
-! BasisEvalAll_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalBasis_Line1
-TYPE(String) :: astr
-astr = UpperCase(refLine)
-
-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
-END SELECT
-
-END PROCEDURE HeirarchicalBasis_Line1
-
-!----------------------------------------------------------------------------
-! HeirarchicalGradientBasis_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalGradientBasis_Line1
-TYPE(String) :: astr
-astr = UpperCase(refLine)
-
-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)
- RETURN
-END SELECT
-
-END PROCEDURE HeirarchicalGradientBasis_Line1
-
-!----------------------------------------------------------------------------
-! OrthogonalBasis_Line
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE OrthogonalBasis_Line1
-INTEGER(I4B) :: ii
-TYPE(String) :: astr
-
-ans = 0.0_DFP
-astr = UpperCase(refLine)
-
-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)
- 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)
- 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)
-
-CASE ("BIUNIT")
- ans = EvalAllOrthopol(&
- & n=order, &
- & x=xij(1, :), &
- & orthopol=basisType, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda)
-
-CASE DEFAULT
- ans = 0.0_DFP
- CALL Errormsg(&
- & msg="No case found for refLine.", &
- & file=__FILE__, &
- & routine="OrthogonalBasis_Line1()", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END SELECT
-
-END PROCEDURE OrthogonalBasis_Line1
-
-!----------------------------------------------------------------------------
-! OrthogonalBasisGradient_Line1
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE OrthogonalBasisGradient_Line1
-TYPE(String) :: astr
-astr = UpperCase(refLine)
-
-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)
- RETURN
-END SELECT
-END PROCEDURE OrthogonalBasisGradient_Line1
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE Methods
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..0e4429343 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,254 @@
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_
+INTEGER(I4B) :: ii
+
+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)
+
+CASE (poly%Monomial)
+
+ nrow = SIZE(x) !! Number of points of evaluation
+ ncol = n + 1 !! Number of basis functions
+
+ ans(1:nrow, 1) = 1.0_DFP
+ DO ii = 1, n
+ ans(1:nrow, ii + 1) = ans(1:nrow, ii) * x(1:nrow)
+ END DO
+
+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_
+INTEGER(I4B) :: indx, ii, jj
+REAL(DFP) :: areal
+
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)
+
+CASE (poly%Monomial)
+ nrow = SIZE(x) !! Number of points of evaluation
+ ncol = n + 1 !! Number of basis functions
+
+ DO jj = 0, n
+ indx = MAX(jj - 1_I4B, 0_I4B)
+ areal = REAL(jj, kind=DFP)
+ DO ii = 1, nrow
+ ans(ii, jj + 1) = areal * (x(ii)**(indx))
+ END DO
+ END DO
+
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/QuadrangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90
deleted file mode 100644
index 31abd7661..000000000
--- a/src/submodules/Polynomial/src/QuadrangleInterpolationUtility@Methods.F90
+++ /dev/null
@@ -1,2023 +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(QuadrangleInterpolationUtility) Methods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! RefElemDomain_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE RefElemDomain_Quadrangle
-ans = "BIUNIT"
-END PROCEDURE RefElemDomain_Quadrangle
-
-!----------------------------------------------------------------------------
-! FacetConnectivity
-!----------------------------------------------------------------------------
-
-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
-END PROCEDURE FacetConnectivity_Quadrangle
-
-!----------------------------------------------------------------------------
-! QuadratureNumber_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE QuadratureNumber_Quadrangle
-ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1)
-ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2)
-END PROCEDURE QuadratureNumber_Quadrangle
-
-!----------------------------------------------------------------------------
-! LagrangeDegree_Quadrangle
-!----------------------------------------------------------------------------
-
-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
-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
-END PROCEDURE LagrangeDegree_Quadrangle2
-
-!----------------------------------------------------------------------------
-! GetTotalDOF_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE GetTotalDOF_Quadrangle
-ans = (order + 1)**2
-END PROCEDURE GetTotalDOF_Quadrangle
-
-!----------------------------------------------------------------------------
-! GetTotalInDOF_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE GetTotalInDOF_Quadrangle
-ans = (order - 1)**2
-END PROCEDURE GetTotalInDOF_Quadrangle
-
-!----------------------------------------------------------------------------
-! LagrangeDOF_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDOF_Quadrangle1
-ans = (order + 1)**2
-END PROCEDURE LagrangeDOF_Quadrangle1
-
-!----------------------------------------------------------------------------
-! LagrangeDOF_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDOF_Quadrangle2
-ans = (p + 1) * (q + 1)
-END PROCEDURE LagrangeDOF_Quadrangle2
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeInDOF_Quadrangle1
-ans = (order - 1)**2
-END PROCEDURE LagrangeInDOF_Quadrangle1
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeInDOF_Quadrangle2
-ans = (p - 1) * (q - 1)
-END PROCEDURE LagrangeInDOF_Quadrangle2
-
-!----------------------------------------------------------------------------
-! EquidistancePoint_Quadrangle
-!----------------------------------------------------------------------------
-
-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
-
-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)
-ELSE
- nsd = 2_I4B
- x = 0.0_DFP
- x(1:2, :) = RefQuadrangleCoord("BIUNIT")
-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]))
-
-END IF
-
-! points on face
-IF (order .GT. 1_I4B) THEN
-
- IF (order .EQ. 2_I4B) THEN
- i1 = i2 + 1
- ans(1:nsd, i1) = SUM(x(1:nsd, :), dim=2_I4B) / 4.0_DFP
- 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)
-
- 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
-
-!----------------------------------------------------------------------------
-! EquidistancePoint_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EquidistancePoint_Quadrangle2
-ans = InterpolationPoint_Quadrangle2( &
- & p=p, &
- & q=q, &
- & xij=xij, &
- & ipType1=Equidistance, &
- & ipType2=Equidistance, &
- & layout="VEFC")
-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
-
-IF (order .LT. 2_I4B) THEN
- ALLOCATE (ans(0, 0))
- RETURN
-END IF
-
-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)
-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]
-END IF
-
-n = LagrangeInDOF_Quadrangle(order=order)
-ALLOCATE (ans(nsd, n))
-ans = 0.0_DFP
-
-! points on face
-IF (order .EQ. 2_I4B) THEN
- ans(1:nsd, 1) = SUM(x, dim=2_I4B) / 4.0_DFP
-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))
-
-END IF
-END PROCEDURE EquidistanceInPoint_Quadrangle1
-
-!----------------------------------------------------------------------------
-! EquidistanceInPoint_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EquidistanceInPoint_Quadrangle2
-END PROCEDURE EquidistanceInPoint_Quadrangle2
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE IJ2VEFC_Quadrangle
-CALL IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, temp, p, q, 1_I4B)
-END PROCEDURE IJ2VEFC_Quadrangle
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise
-! internal variables
-INTEGER(I4B) :: cnt, m, ii, jj, kk, 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(:, :)
-
-! 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
-
-IF (ALL([p, q] .EQ. 0_I4B)) THEN
- temp(:, 1) = [xi(1, 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]
-
-IF (ALL([p, q] .GE. 1_I4B)) THEN
- DO ii = 1, 4
- cnt = cnt + 1
- jj = pointsOrder(ii)
- temp(1:2, ii) = [ &
- & xi(ij(1, jj), ij(2, jj)), &
- & eta(ij(1, jj), ij(2, jj)) &
- & ]
- END DO
- IF (ALL([p, q] .EQ. 1_I4B)) RETURN
-
-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
-
- 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
-
-END IF
-
-IF (ALL([p, q] .GE. 1_I4B)) THEN
- 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 (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
-
- 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
-
- 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))
-
- 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
- END IF
-
-END IF
-
-IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in)
-IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in)
-IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in)
-
-END PROCEDURE IJ2VEFC_Quadrangle_Clockwise
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise
-! internal variables
-INTEGER(I4B) :: cnt, m, ii, jj, kk, 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(:, :)
-
-! 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
-
-IF (ALL([p, q] .EQ. 0_I4B)) THEN
- temp(:, 1) = [xi(1, 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]
-
-IF (ALL([p, q] .GE. 1_I4B)) THEN
- DO ii = 1, 4
- cnt = cnt + 1
- jj = pointsOrder(ii)
- temp(1:2, ii) = [&
- & xi(ij(1, jj), ij(2, jj)), &
- & eta(ij(1, jj), ij(2, jj)) &
- & ]
- END DO
- IF (ALL([p, q] .EQ. 1_I4B)) RETURN
-
-ELSE
- DO ii = 1, MIN(p, 1) + 1
- DO jj = 1, MIN(q, 1) + 1
- cnt = cnt + 1
- temp(1:2, cnt) = [&
- & xi(ij(1, cnt), ij(2, cnt)), &
- & eta(ij(1, cnt), ij(2, cnt))]
- END DO
- END DO
-END IF
-
-IF (ALL([p, q] .GE. 1_I4B)) THEN
- 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 (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
-
- 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
-
- 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))
-
- 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_AntiClockwise( &
- & 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
- END IF
-
-END IF
-
-IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in)
-IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in)
-IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in)
-
-END PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Quadrangle
-!----------------------------------------------------------------------------
-
-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 &
- & )
-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)
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
-
-CALL Reallocate(ans, nsd, (p + 1) * (q + 1))
-CALL Reallocate(temp, 2, (p + 1) * (q + 1))
-
-xi = 0.0_DFP
-eta = 0.0_DFP
-
-DO ii = 1, p + 1
- DO jj = 1, q + 1
- xi(ii, jj) = x(ii)
- eta(ii, jj) = 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
-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
-END IF
-END PROCEDURE InterpolationPoint_Quadrangle2
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Quadrangle1
-REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
-INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
-INTEGER(I4B) :: info
-ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP
-V = LagrangeVandermonde(order=order, xij=xij, elemType=Quadrangle)
-CALL GetLU(A=V, IPIV=ipiv, info=info)
-CALL LUSolve(A=V, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Quadrangle1
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Quadrangle2
-
-REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp
-INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv
-INTEGER(I4B) :: info
-vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B
-CALL GetLU(A=vtemp, IPIV=ipiv, info=info)
-CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Quadrangle2
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Quadrangle3
-INTEGER(I4B) :: info
-ans = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Quadrangle3
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Quadrangle4
-INTEGER(I4B) :: basisType0, ii, jj, indx
-REAL(DFP) :: ans1(SIZE(xij, 2), 0:order)
-REAL(DFP) :: ans2(SIZE(xij, 2), 0:order)
-
-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)
-END IF
-
-CALL GetInvMat(ans)
-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)
-
-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)
-END IF
-
-CALL GetInvMat(ans)
-END PROCEDURE LagrangeCoeff_Quadrangle5
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Dubiner_Quadrangle1
-INTEGER(I4B) :: nrow, ncol
-CALL Dubiner_Quadrangle1_(xij=xij, order=order, ans=ans, nrow=nrow, &
- ncol=ncol)
-END PROCEDURE Dubiner_Quadrangle1
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Dubiner_Quadrangle1_
-REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1)
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2))
-REAL(DFP) :: avec(SIZE(xij, 2)), alpha, beta
-INTEGER(I4B) :: k1, k2, max_k2, cnt
-
-x = xij(1, :)
-y = xij(2, :)
-nrow = SIZE(xij, 2)
-ncol = (order + 1) * (order + 2) / 2
-
-P1 = LegendreEvalAll(n=order, x=x)
-
-! we do not need x now, so let store (1-y)/2 in x
-x = 0.5_DFP * (1.0_DFP - y)
-alpha = 0.0_DFP
-beta = 0.0_DFP
-cnt = 0
-
-DO k1 = 0, order
-
- avec = (x)**k1 ! note here x = 0.5_DFP*(1-y)
- alpha = 2.0_DFP * k1 + 1.0_DFP
-
- max_k2 = order - k1
-
- P2(:, 1:max_k2 + 1) = JacobiEvalAll(n=max_k2, x=y, alpha=alpha, beta=beta)
-
- DO k2 = 0, max_k2
- cnt = cnt + 1
- ans(:, cnt) = P1(:, k1 + 1) * avec * P2(:, k2 + 1)
- END DO
-
-END DO
-
-END PROCEDURE Dubiner_Quadrangle1_
-
-!----------------------------------------------------------------------------
-! DubinerGradient_Quadrangle1
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE DubinerGradient_Quadrangle1
-INTEGER(I4B) :: s(3)
-CALL DubinerGradient_Quadrangle1_(xij=xij, order=order, ans=ans, &
- tsize1=s(1), tsize2=s(2), tsize3=s(3))
-END PROCEDURE DubinerGradient_Quadrangle1
-
-!----------------------------------------------------------------------------
-! DubinerGradient_Quadrangle1
-!----------------------------------------------------------------------------
-
-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
-
-tsize1 = SIZE(xij, 2)
-tsize2 = (order + 1) * (order + 2) / 2
-tsize3 = 2
-
-x = xij(1, :)
-y = xij(2, :)
-P1 = LegendreEvalAll(n=order, x=x)
-dP1 = LegendreGradientEvalAll(n=order, x=x)
-
-! we do not need x now, so let store (1-y)/2 in x
-x = 0.5_DFP * (1.0_DFP - y)
-alpha = 1.0_DFP
-beta = 0.0_DFP
-cnt = 0
-
-DO k1 = 0, order
- bvec = x**(MAX(k1 - 1_I4B, 0_I4B))
- avec = x * bvec
- 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)
-
- dP2(:, 1:max_k2 + 1) = JacobiGradientEvalAll( &
- & n=max_k2, &
- & x=y, &
- & alpha=alpha, &
- & beta=beta)
-
- 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))
- END DO
-END DO
-END PROCEDURE DubinerGradient_Quadrangle1_
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Dubiner_Quadrangle2
-INTEGER(I4B) :: nrow, ncol
-CALL Dubiner_Quadrangle2_(x=x, y=y, order=order, ans=ans, nrow=nrow, &
- ncol=ncol)
-END PROCEDURE Dubiner_Quadrangle2
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE Dubiner_Quadrangle2_
-REAL(DFP) :: xij(2, SIZE(x) * SIZE(y))
-INTEGER(I4B) :: ii, jj, cnt
-
-xij = 0.0_DFP
-cnt = 0
-DO ii = 1, SIZE(x)
- DO jj = 1, SIZE(y)
- cnt = cnt + 1
- xij(1, cnt) = x(ii)
- xij(2, cnt) = y(jj)
- END DO
-END DO
-CALL Dubiner_Quadrangle1_(order=order, xij=xij, ans=ans, nrow=nrow, &
- ncol=ncol)
-END PROCEDURE Dubiner_Quadrangle2_
-
-!----------------------------------------------------------------------------
-! TensorProdOrthoPol_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE TensorProdBasis_Quadrangle1
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2))
-REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1)
-INTEGER(I4B) :: ii, k1, k2, cnt
-
-x = xij(1, :)
-y = xij(2, :)
-
-P1 = 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)
-
-cnt = 0
-
-DO k2 = 1, q + 1
- DO k1 = 1, p + 1
- cnt = cnt + 1
- ans(:, cnt) = P1(:, k1) * Q1(:, k2)
- END DO
-END DO
-
-END PROCEDURE TensorProdBasis_Quadrangle1
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE TensorProdBasis_Quadrangle2
-REAL(DFP) :: xij(2, SIZE(x) * SIZE(y))
-INTEGER(I4B) :: ii, jj, cnt
-
-xij = 0.0_DFP
-cnt = 0
-DO ii = 1, SIZE(x)
- DO jj = 1, SIZE(y)
- cnt = cnt + 1
- xij(1, cnt) = x(ii)
- xij(2, cnt) = y(jj)
- END DO
-END DO
-
-ans = TensorProdBasis_Quadrangle1( &
- & p=p, &
- & q=q, &
- & xij=xij, &
- & basisType1=basisType1, &
- & basisType2=basisType2, &
- & alpha1=alpha1, &
- & alpha2=alpha2, &
- & beta1=beta1, &
- & beta2=beta2, &
- & lambda1=lambda1, &
- & lambda2=lambda2)
-
-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)
-END PROCEDURE VertexBasis_Quadrangle1
-
-!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle2
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE VertexBasis_Quadrangle2
-ans(:, 1) = L1(:, 0) * L2(:, 0)
-ans(:, 2) = L1(:, 1) * L2(:, 0)
-ans(:, 3) = L1(:, 1) * L2(:, 1)
-ans(:, 4) = L1(:, 0) * L2(:, 1)
-END PROCEDURE VertexBasis_Quadrangle2
-
-!----------------------------------------------------------------------------
-! 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
-
-!----------------------------------------------------------------------------
-! VertexBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE VertexBasis_Quadrangle3
-ans = VertexBasis_Quadrangle1( &
- & x=xij(1, :), &
- & y=xij(2, :))
-END PROCEDURE VertexBasis_Quadrangle3
-
-!----------------------------------------------------------------------------
-! VerticalEdgeBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE VerticalEdgeBasis_Quadrangle
-REAL(DFP) :: L2(1:SIZE(y), 0:MAX(qe1, qe2))
-INTEGER(I4B) :: maxQ, k2, cnt
-
-maxQ = MAX(qe1, qe2)
-
-L2 = LobattoEvalAll(n=maxQ, x=y)
-
-cnt = 0
-
-DO k2 = 2, qe1
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP - x) * L2(:, k2)
-END DO
-
-DO k2 = 2, qe2
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP + x) * L2(:, k2)
-END DO
-
-END PROCEDURE VerticalEdgeBasis_Quadrangle
-
-!----------------------------------------------------------------------------
-! VerticalEdgeBasis_Quadrangle2
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE VerticalEdgeBasis_Quadrangle2
-INTEGER(I4B) :: k2, cnt
-
-cnt = 0
-DO k2 = 2, qe1
- cnt = cnt + 1
- ans(:, cnt) = L1(:, 0) * L2(:, k2)
-END DO
-DO k2 = 2, qe2
- cnt = cnt + 1
- ans(:, cnt) = L1(:, 1) * L2(:, k2)
-END DO
-
-END PROCEDURE VerticalEdgeBasis_Quadrangle2
-
-!----------------------------------------------------------------------------
-! 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
-
-!----------------------------------------------------------------------------
-! HorizontalEdgeBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle
-REAL(DFP) :: L1(1:SIZE(x), 0:MAX(pe3, pe4))
-INTEGER(I4B) :: maxP, k1, cnt
-
-maxP = MAX(pe3, pe4)
-
-L1 = LobattoEvalAll(n=maxP, x=x)
-
-cnt = 0
-
-DO k1 = 2, pe3
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP - y) * L1(:, k1)
-END DO
-
-DO k1 = 2, pe4
- cnt = cnt + 1
- ans(:, cnt) = 0.5_DFP * (1.0_DFP + y) * L1(:, k1)
-END DO
-
-END PROCEDURE HorizontalEdgeBasis_Quadrangle
-
-!----------------------------------------------------------------------------
-! HorizontalEdgeBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle2
-INTEGER(I4B) :: k1, cnt
-cnt = 0
-DO k1 = 2, pe3
- cnt = cnt + 1
- ans(:, cnt) = L1(:, k1) * L2(:, 0)
-END DO
-DO k1 = 2, pe4
- cnt = cnt + 1
- ans(:, cnt) = L1(:, k1) * L2(:, 1)
-END DO
-END PROCEDURE HorizontalEdgeBasis_Quadrangle2
-
-!----------------------------------------------------------------------------
-! 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
-
-!----------------------------------------------------------------------------
-! CellBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE CellBasis_Quadrangle
-REAL(DFP) :: L1(1:SIZE(x), 0:pb)
-REAL(DFP) :: L2(1:SIZE(y), 0:qb)
-INTEGER(I4B) :: k1, k2, cnt
-
-L1 = LobattoEvalAll(n=pb, x=x)
-L2 = LobattoEvalAll(n=qb, x=y)
-
-cnt = 0
-
-DO k1 = 2, pb
- DO k2 = 2, qb
- cnt = cnt + 1
- ans(:, cnt) = L1(:, k1) * L2(:, k2)
- END DO
-END DO
-
-END PROCEDURE CellBasis_Quadrangle
-
-!----------------------------------------------------------------------------
-! CellBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE CellBasis_Quadrangle2
-INTEGER(I4B) :: k1, k2, cnt
-cnt = 0
-DO k1 = 2, pb
- DO k2 = 2, qb
- cnt = cnt + 1
- ans(:, cnt) = L1(:, k1) * L2(:, k2)
- END DO
-END DO
-END PROCEDURE CellBasis_Quadrangle2
-
-!----------------------------------------------------------------------------
-! 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)
- END DO
-END DO
-END PROCEDURE 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))
-
-maxP = MAX(pe3, pe4, pb)
-maxQ = MAX(qe1, qe2, qb)
-
-L1 = LobattoEvalAll(n=maxP, x=xij(1, :))
-L2 = LobattoEvalAll(n=maxQ, x=xij(2, :))
-
-! Vertex basis function
-
-ans(:, 1:4) = VertexBasis_Quadrangle2(L1=L1, L2=L2)
-
-! Edge basis function
-
-b = 4
-!
-IF (qe1 .GE. 2_I4B .OR. qe2 .GE. 2_I4B) THEN
- a = b + 1
- b = a - 1 + qe1 + qe2 - 2 !4+qe1 + qe2 - 2
- ans(:, a:b) = VerticalEdgeBasis_Quadrangle2( &
- & qe1=qe1, qe2=qe2, L1=L1, L2=L2)
-END IF
-
-! Edge basis function
-
-IF (pe3 .GE. 2_I4B .OR. pe4 .GE. 2_I4B) THEN
- a = b + 1
- b = a - 1 + pe3 + pe4 - 2 !4+pe3 + pe4 - 2
- ans(:, a:b) = HorizontalEdgeBasis_Quadrangle2( &
- & pe3=pe3, pe4=pe4, L1=L1, L2=L2)
-END IF
-
-! Cell basis function
-
-IF (pb .GE. 2_I4B .OR. qb .GE. 2_I4B) THEN
- a = b + 1
- b = a - 1 + (pb - 1) * (qb - 1)
- ans(:, a:b) = CellBasis_Quadrangle2(pb=pb, qb=qb, L1=L1, L2=L2)
-END IF
-END PROCEDURE HeirarchicalBasis_Quadrangle1
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalBasis_Quadrangle2
-ans = HeirarchicalBasis_Quadrangle1(pb=p, pe3=p, pe4=p, &
- & qb=q, qe1=q, qe2=q, xij=xij)
-END PROCEDURE HeirarchicalBasis_Quadrangle2
-
-!----------------------------------------------------------------------------
-! LagrangeEvallAll_Quadrangle
-!----------------------------------------------------------------------------
-
-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))
-
-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)
- END IF
-ELSE
- coeff0 = TRANSPOSE(LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & ))
-END IF
-
-SELECT CASE (basisType0)
-
-CASE (Monomial)
-
- degree = LagrangeDegree_Quadrangle(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_Quadrangle1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
-
- DO ii = 1, tdof
- xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2)
- END DO
-
-CASE (Heirarchical)
-
- xx = HeirarchicalBasis_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=RESHAPE(x, [2, 1]))
-
-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)
-
-END SELECT
-
-ans = MATMUL(coeff0, xx(1, :))
-
-END PROCEDURE LagrangeEvalAll_Quadrangle1
-
-!----------------------------------------------------------------------------
-! 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))
-
-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
- END IF
-ELSE
- coeff0 = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
-END IF
-
-SELECT CASE (basisType0)
-
-CASE (Monomial)
-
- degree = LagrangeDegree_Quadrangle(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_Quadrangle1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
-
- DO ii = 1, tdof
- xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2)
- END DO
-
-CASE (Heirarchical)
-
- xx = HeirarchicalBasis_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=x)
-
-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)
-
-END SELECT
-
-ans = MATMUL(xx, coeff0)
-
-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 &
- & )
-END PROCEDURE QuadraturePoint_Quadrangle1
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE QuadraturePoint_Quadrangle2
-! internal variables
-REAL(DFP), ALLOCATABLE :: x(:, :), y(:, :), temp(:, :)
-INTEGER(I4B) :: ii, jj, kk, nsd, np, nq
-TYPE(String) :: astr
-
-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)
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
-
-CALL Reallocate(ans, nsd + 1_I4B, np * nq)
-CALL Reallocate(temp, 3_I4B, np * nq)
-
-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
-
-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)
-
-END PROCEDURE QuadraturePoint_Quadrangle2
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle
-!----------------------------------------------------------------------------
-
-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 &
- & )
-END PROCEDURE QuadraturePoint_Quadrangle3
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-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
-
-astr = TRIM(UpperCase(refQuadrangle))
-
-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)
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
-
-CALL Reallocate(ans, nsd + 1_I4B, np * nq)
-
-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
-
-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
-
-END PROCEDURE QuadraturePoint_Quadrangle4
-
-!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeGradientEvalAll_Quadrangle1
-LOGICAL(LGT) :: firstCall0
-INTEGER(I4B) :: ii, basisType0, tdof, ai, bi
-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
-
-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
- END IF
-ELSE
- coeff0 = LagrangeCoeff_Quadrangle(&
- & order=order, &
- & xij=xij, &
- & basisType=basisType0, &
- & alpha=alpha, &
- & beta=beta, &
- & lambda=lambda &
- & )
-END IF
-
-SELECT CASE (basisType0)
-
-CASE (Monomial)
-
- degree = LagrangeDegree_Quadrangle(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_Quadrangle1", &
- & line=__LINE__, &
- & unitno=stderr)
- END IF
-
- DO ii = 1, tdof
- 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)
- END DO
-
-CASE (Heirarchical)
-
- xx = HeirarchicalBasisGradient_Quadrangle( &
- & p=order, &
- & q=order, &
- & xij=x)
-
-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)
-
-END SELECT
-
-DO ii = 1, 2
- ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
- ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0)
-END DO
-
-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))
-
-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, :))
-
-! Vertex basis function
-ans(:, 1:4, 1:2) = VertexBasisGradient_Quadrangle2( &
-& L1=L1, &
-& L2=L2, &
-& dL1=dL1, &
-& dL2=dL2 &
-& )
-
-! 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 &
- & )
-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 &
- & )
-END IF
-END PROCEDURE HeirarchicalBasisGradient_Quadrangle1
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Quadrangle
-!----------------------------------------------------------------------------
-
-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
-
-!----------------------------------------------------------------------------
-! TensorProdBasisGradient_Quadrangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1
-REAL(DFP) :: x(SIZE(xij, 2)), y(SIZE(xij, 2))
-REAL(DFP) :: P1(SIZE(xij, 2), p + 1), Q1(SIZE(xij, 2), q + 1)
-REAL(DFP) :: dP1(SIZE(xij, 2), p + 1), dQ1(SIZE(xij, 2), q + 1)
-INTEGER(I4B) :: ii, k1, k2, cnt
-
-x = xij(1, :)
-y = xij(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)
-
-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)
- END DO
-END DO
-
-END PROCEDURE TensorProdBasisGradient_Quadrangle1
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Quadrangle3
-!----------------------------------------------------------------------------
-
-END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90 b/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90
deleted file mode 100644
index 810e3c6cb..000000000
--- a/src/submodules/Polynomial/src/QuadraturePoint_Tetrahedron_Solin.F90
+++ /dev/null
@@ -1,3449 +0,0 @@
-! This program is a part of EASIFEM library
-! Copyright (C) 2020-2021 Vikas Sharma, Ph.D
-!
-! This program is free software: you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation, either version 3 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License
-! along with this program. If not, see
-!
-
-MODULE QuadraturePoint_Tetrahedron_Solin
-USE GlobalData, ONLY: DFP, I4B, LGT
-IMPLICIT NONE
-PRIVATE
-PUBLIC :: QuadraturePointTetrahedronSolin
-PUBLIC :: QuadratureOrderTetrahedronSolin
-PUBLIC :: QuadratureNumberTetrahedronSolin
-INTEGER( I4B ), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN=21
-
-CONTAINS
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: nips
- INTEGER(I4B) :: ans
- ans = -1
- SELECT CASE (nips)
- CASE (1)
- ans = 1
- CASE (4)
- ans = 2
- CASE (5)
- ans = 3
- CASE (11)
- ans = 4
- CASE (14)
- ans = 5
- CASE (24)
- ans = 6
- CASE (31)
- ans = 7
- CASE (43)
- ans = 8
- CASE (53)
- ans = 9
- CASE (126)
- ans = 11
- CASE (210)
- ans = 13
- CASE (330)
- ans = 15
- CASE (495)
- ans = 17
- CASE (715)
- ans = 19
- CASE (1001)
- ans = 21
- END SELECT
-END FUNCTION QuadratureOrderTetrahedronSolin
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans)
- INTEGER(I4B), INTENT(IN) :: order
- INTEGER(I4B) :: ans
- ans = -1
- SELECT CASE (order)
- CASE (0, 1)
- ans = 1
- CASE (2)
- ans = 4
- CASE (3)
- ans = 5
- CASE (4)
- ans = 11
- CASE (5)
- ans = 14
- CASE (6)
- ans = 24
- CASE (7)
- ans = 31
- CASE (8)
- ans = 43
- CASE (9)
- ans = 53
- CASE (10)
- ans = 126
- CASE (11)
- ans = 126
- CASE (12)
- ans = 210
- CASE (13)
- ans = 210
- CASE (14)
- ans = 330
- CASE (15)
- ans = 330
- CASE (16)
- ans = 495
- CASE (17)
- ans = 495
- CASE (18)
- ans = 715
- CASE (19)
- ans = 715
- CASE (20)
- ans = 1001
- CASE (21)
- ans = 1001
- END SELECT
-END FUNCTION QuadratureNumberTetrahedronSolin
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-PURE FUNCTION QuadraturePointTetrahedronSolin(order) RESULT(ans)
- REAL(DFP), ALLOCATABLE :: ans(:, :)
- INTEGER(I4B), INTENT(IN) :: order
- SELECT CASE (order)
- CASE (0, 1)
- ans = QP_Tetrahedron_Order1()
- CASE (2)
- ans = QP_Tetrahedron_Order2()
- CASE (3)
- ans = QP_Tetrahedron_Order3()
- CASE (4)
- ans = QP_Tetrahedron_Order4()
- CASE (5)
- ans = QP_Tetrahedron_Order5()
- CASE (6)
- ans = QP_Tetrahedron_Order6()
- CASE (7)
- ans = QP_Tetrahedron_Order7()
- CASE (8)
- ans = QP_Tetrahedron_Order8()
- CASE (9)
- ans = QP_Tetrahedron_Order9()
- CASE (10)
- ans = QP_Tetrahedron_Order10()
- CASE (11)
- ans = QP_Tetrahedron_Order11()
- CASE (12)
- ans = QP_Tetrahedron_Order12()
- CASE (13)
- ans = QP_Tetrahedron_Order13()
- CASE (14)
- ans = QP_Tetrahedron_Order14()
- CASE (15)
- ans = QP_Tetrahedron_Order15()
- CASE (16)
- ans = QP_Tetrahedron_Order16()
- CASE (17)
- ans = QP_Tetrahedron_Order17()
- CASE (18)
- ans = QP_Tetrahedron_Order18()
- CASE (19)
- ans = QP_Tetrahedron_Order19()
- CASE (20)
- ans = QP_Tetrahedron_Order20()
- CASE (21)
- ans = QP_Tetrahedron_Order21()
- 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
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-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/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
deleted file mode 100644
index df48713f1..000000000
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
+++ /dev/null
@@ -1,666 +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(TriangleInterpolationUtility) HeirarchicalBasisMethods
-USE LobattoPolynomialUtility, ONLY: LobattoKernelEvalAll_, &
- LobattoKernelGradientEvalAll_
-USE MappingUtility, ONLY: BarycentricCoordTriangle_
-
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! 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
-
-!----------------------------------------------------------------------------
-! VertexBasis_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE VertexBasis_Triangle
-REAL(DFP) :: lambda(3, SIZE(xij, 2))
-CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans)
-END PROCEDURE VertexBasis_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)
-
-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
-
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=ii, ncol=jj)
-
-CALL BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
- lambda=lambda, phi=phi, ans=ans)
-
-END PROCEDURE BarycentricEdgeBasis_Triangle
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 30 Oct 2022
-! summary: Evaluate the edge basis on triangle using barycentric coordinate
-! (internal only)
-
-MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, &
- lambda, phi, ans)
- INTEGER(I4B), INTENT(IN) :: pe1
- !! order on edge (e1)
- INTEGER(I4B), INTENT(IN) :: pe2
- !! order on edge (e2)
- INTEGER(I4B), INTENT(IN) :: pe3
- !! order on edge (e3)
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation in terms of barycentric coordinates
- !! size(lambda,1) = 3
- !! size(lambda,2) = number of points of evaluation
- REAL(DFP), INTENT(IN) :: phi(1:, 0:)
- !! lobatto kernel values
- !! size(phi1, 1) = 3*number of points (lambda2-lambda1),
- !! (lambda3-lambda1), (lambda3-lambda2)
- !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP), INTENT(INOUT) :: ans(SIZE(lambda, 2), pe1 + pe2 + pe3 - 3)
-
- INTEGER(I4B) :: tPoints, a, ii
- REAL(DFP) :: temp(SIZE(lambda, 2))
- !FIXME: Remove this temp, I want no allocation in this routine
-
- ans = 0.0_DFP
- tPoints = SIZE(lambda, 2)
- a = 0
-
- !FIXME: Make these loop parallel
-
- ! edge(1) = 1 -> 2
- temp = lambda(1, :) * lambda(2, :)
- DO ii = 1, pe1 - 1
- ans(:, a + ii) = temp * phi(1:tPoints, ii - 1)
- 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)
- 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)
- END DO
-END SUBROUTINE BarycentricEdgeBasis_Triangle2
-
-!----------------------------------------------------------------------------
-! EdgeBasis_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EdgeBasis_Triangle
-REAL(DFP) :: lambda(3, SIZE(xij, 2))
-CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricEdgeBasis_Triangle(lambda=lambda, ans=ans, pe1=pe1, &
- pe2=pe2, pe3=pe3)
-END PROCEDURE EdgeBasis_Triangle
-
-!----------------------------------------------------------------------------
-! BarycentricEdgeBasis_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
-
-tPoints = SIZE(lambda, 2)
-maxP = order - 2
-
-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)
-
-END PROCEDURE BarycentricCellBasis_Triangle
-
-!----------------------------------------------------------------------------
-! BarycentricCellBasis_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Eval basis in the cell of reference triangle (internal only)
-
-PURE SUBROUTINE BarycentricCellBasis_Triangle2(order, lambda, phi, ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order in the cell of triangle, it should be greater than 2
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation 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
- REAL(DFP), INTENT(INOUT) :: ans(:, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2))
-
- INTEGER(I4B) :: tp, k1, k2, cnt
- REAL(DFP) :: temp(SIZE(lambda, 2))
- !! FIXME: Remove this temp from there, no allocation is our goal
-
- tp = SIZE(lambda, 2)
- temp = lambda(1, :) * lambda(2, :) * lambda(3, :)
- cnt = 0
-
- ! FIXME: Make this loop parallel
-
- DO k1 = 1, order - 2
- DO k2 = 1, order - 1 - k1
- cnt = cnt + 1
- ans(:, cnt) = temp * phi(1:tp, k1 - 1) * &
- & phi(1 + 2 * tp:3 * tp, k2 - 1)
- END DO
- END DO
-
-END SUBROUTINE BarycentricCellBasis_Triangle2
-
-!----------------------------------------------------------------------------
-! CellBasis_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE CellBasis_Triangle
-REAL(DFP) :: lambda(3, SIZE(xij, 2))
-CALL BarycentricCoordTriangle_(ans=lambda, refTriangle=refTriangle, xin=xij)
-CALL BarycentricCellBasis_Triangle(lambda=lambda, ans=ans, order=order)
-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
-
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
-
-! Vertex basis function
-ans = 0.0_DFP
-CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3))
-
-! 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 BarycentricEdgeBasis_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, &
- lambda=lambda, phi=phi, ans=ans(:, a:b))
-END IF
-
-! 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
-
-END PROCEDURE BarycentricHeirarchicalBasis_Triangle1
-
-!----------------------------------------------------------------------------
-! BarycentricHeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-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
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalBasis_Triangle1
-INTEGER(I4B) :: nrow, ncol
-CALL HeirarchicalBasis_Triangle1_(order=order, pe1=pe1, pe2=pe2, pe3=pe3, &
- xij=xij, refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
-END PROCEDURE HeirarchicalBasis_Triangle1
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-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)
-END PROCEDURE HeirarchicalBasis_Triangle1_
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalBasis_Triangle2
-INTEGER(I4B) :: nrow, ncol
-CALL HeirarchicalBasis_Triangle2_(order=order, xij=xij, &
- refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
-END PROCEDURE HeirarchicalBasis_Triangle2
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasis_Triangle
-!----------------------------------------------------------------------------
-
-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)
-END PROCEDURE HeirarchicalBasis_Triangle2_
-
-!----------------------------------------------------------------------------
-! BarycentricVertexBasisGradient_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
-
-!----------------------------------------------------------------------------
-! 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
-
-tPoints = SIZE(lambda, 2)
-maxP = MAX(pe1 - 2, pe2 - 2, pe3 - 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
-
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
-
-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)
-
-END PROCEDURE BarycentricEdgeBasisGradient_Triangle
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-!> author: Shion Shimizu and Vikas Sharma, Ph. D.
-! date: 2024-04-21
-! summary: Evaluate the gradient of the edge basis on triangle
-! using barycentric coordinate
-
-PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle2(pe1, pe2, pe3, &
- lambda, phi, gradientPhi, ans)
- INTEGER(I4B), INTENT(IN) :: pe1
- !! order on edge (e1)
- INTEGER(I4B), INTENT(IN) :: pe2
- !! order on edge (e2)
- INTEGER(I4B), INTENT(IN) :: pe3
- !! order on edge (e3)
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation in terms of barycentric coordinates
- !! size(lambda,1) = 3
- !! size(lambda,2) = number of points of evaluation
- REAL(DFP), INTENT(IN) :: phi(1:, 0:)
- !! lobatto kernel values
- !! size(phi1, 1) = 3*number of points (lambda2-lambda1),
- !! (lambda3-lambda1), (lambda3-lambda2)
- !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
- REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:)
- !! 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
-
- 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
- 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
-
- ans(1:tp, a + ii, 2) = lambda(3, :) * &
- phi(1 + tp:2 * tp, ii - 1) - &
- temp * gradientPhi(1 + tp:2 * tp, ii - 1)
-
- 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)
-
- ans(1:tp, a + ii, 2) = 0.0_DFP
-
- 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
-
-!----------------------------------------------------------------------------
-! BarycentricVertexBasisGradient_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE BarycentricCellBasisGradient_Triangle
-INTEGER(I4B) :: a, b, ii, maxP, tp
-REAL(DFP), ALLOCATABLE :: phi(:, :), gradientPhi(:, :), d_lambda(:)
-
-tp = SIZE(lambda, 2)
-maxP = order - 2
-
-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
-
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
-
-CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
- nrow=a, ncol=b)
-
-CALL BarycentricCellBasisGradient_Triangle2(order=order, lambda=lambda, &
- phi=phi, gradientPhi=gradientPhi, ans=ans)
-END PROCEDURE BarycentricCellBasisGradient_Triangle
-
-!----------------------------------------------------------------------------
-! BarycentricCellBasisGradient_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Shion Shimizu
-! date: 2024-04-21
-! summary: Evaluate the gradient of the cell basis on triangle
-
-PURE SUBROUTINE BarycentricCellBasisGradient_Triangle2(order, lambda, phi, &
- gradientPhi, ans)
- INTEGER(I4B), INTENT(IN) :: order
- !! order in the cell of triangle, it should be greater than 2
- REAL(DFP), INTENT(IN) :: lambda(:, :)
- !! point of evaluation
- REAL(DFP), INTENT(IN) :: phi(1:, 0:)
- !! lobatto kernel values
- !! size(phi1, 1) = 3*number of points (lambda2-lambda1),
- !! (lambda3-lambda1), (lambda3-lambda2)
- !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
- REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:)
- !! gradients of lobatto kernel functions
- REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
- ! REAL(DFP) :: ans(SIZE(lambda, 2), INT((order - 1) * (order - 2) / 2), 3)
-
- ! 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))
-
- ! FIXME: Remove these temps
-
- 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)
- END DO
- END DO
-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
-
-CALL LobattoKernelEvalAll_(n=maxP, x=d_lambda, ans=phi, nrow=a, ncol=b)
-
-CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
- nrow=a, ncol=b)
-
-! 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 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
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1
-INTEGER(I4B) :: s(3)
-CALL HeirarchicalBasisGradient_Triangle1_(order=order, pe1=pe1, &
- pe2=pe2, pe3=pe3, xij=xij, refTriangle=refTriangle, ans=ans, tsize1=s(1), &
- tsize2=s(2), tsize3=s(3))
-END PROCEDURE HeirarchicalBasisGradient_Triangle1
-
-!----------------------------------------------------------------------------
-! HeirarchicalBasisGradient_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1_
-REAL(DFP) :: jac(3, 2)
-REAL(DFP), ALLOCATABLE :: lambda(:, :), dPhi(:, :, :)
-INTEGER(I4B) :: ii, jj, kk
-
-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)
-
-SELECT CASE (refTriangle(1:1))
-CASE ("B", "b")
- jac(1, :) = [-0.50_DFP, -0.50_DFP]
- jac(2, :) = [0.50_DFP, 0.0_DFP]
- jac(3, :) = [0.0_DFP, 0.50_DFP]
-CASE ("U", "u")
- jac(1, :) = [-1.0_DFP, -1.0_DFP]
- jac(2, :) = [1.0_DFP, 0.0_DFP]
- jac(3, :) = [0.0_DFP, 1.0_DFP]
-END SELECT
-
-DO CONCURRENT(ii=1:tsize1, jj=1:tsize2, kk=1:tsize3)
- ans(ii, jj, kk) = dPhi(ii, jj, 1) * jac(1, kk) &
- + dPhi(ii, jj, 2) * jac(2, kk) &
- + dPhi(ii, jj, 3) * jac(3, kk)
-END DO
-
-DEALLOCATE (lambda, dPhi)
-
-END PROCEDURE HeirarchicalBasisGradient_Triangle1_
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE HeirarchicalBasisMethods
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
deleted file mode 100644
index 50fd1448c..000000000
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
+++ /dev/null
@@ -1,346 +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(TriangleInterpolationUtility) LagrangeBasisMethods
-USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_
-USE ErrorHandling, ONLY: Errormsg
-USE InputUtility, ONLY: Input
-USE GE_CompRoutineMethods, ONLY: GetInvMat
-USE GE_LUMethods, ONLY: LUSolve, GetLU
-
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! LagrangeDegree_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDegree_Triangle
-INTEGER(I4B) :: nrow, ncol
-nrow = (order + 1) * (order + 2) / 2_I4B
-ncol = 2
-ALLOCATE (ans(nrow, ncol))
-CALL LagrangeDegree_Triangle_(order=order, ans=ans, ncol=ncol, nrow=nrow)
-END PROCEDURE LagrangeDegree_Triangle
-
-!----------------------------------------------------------------------------
-! LagrangeDegree_Triangle_
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDegree_Triangle_
-INTEGER(I4B) :: ii, jj, kk
-
-nrow = (order + 1) * (order + 2) / 2_I4B
-ncol = 2
-
-kk = 0
-DO jj = 0, order
- DO ii = 0, order - jj
- kk = kk + 1
- ans(kk, 1) = ii
- ans(kk, 2) = jj
- END DO
-END DO
-
-END PROCEDURE LagrangeDegree_Triangle_
-
-!----------------------------------------------------------------------------
-! LagrangeDOF_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeDOF_Triangle
-ans = (order + 1) * (order + 2) / 2_I4B
-END PROCEDURE LagrangeDOF_Triangle
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeInDOF_Triangle
-ans = (order - 1) * (order - 2) / 2_I4B
-END PROCEDURE LagrangeInDOF_Triangle
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Triangle1
-REAL(DFP), DIMENSION(SIZE(xij, 2), SIZE(xij, 2)) :: V
-INTEGER(I4B), DIMENSION(SIZE(xij, 2)) :: ipiv
-INTEGER(I4B) :: info, nrow, ncol
-
-ipiv = 0_I4B; ans = 0.0_DFP; ans(i) = 1.0_DFP
-
-CALL LagrangeVandermonde_(order=order, xij=xij, elemType=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
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Triangle2
-REAL(DFP), DIMENSION(SIZE(v, 1), SIZE(v, 2)) :: vtemp
-INTEGER(I4B), DIMENSION(SIZE(v, 1)) :: ipiv
-INTEGER(I4B) :: info
-
-vtemp = v; ans = 0.0_DFP; ans(i) = 1.0_DFP; ipiv = 0_I4B
-CALL GetLU(A=vtemp, IPIV=ipiv, info=info)
-CALL LUSolve(A=vtemp, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Triangle2
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Triangle3
-INTEGER(I4B) :: info
-ans = 0.0_DFP; ans(i) = 1.0_DFP
-CALL LUSolve(A=v, B=ans, IPIV=ipiv, info=info)
-END PROCEDURE LagrangeCoeff_Triangle3
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Triangle4
-INTEGER(I4B) :: basisType0, nrow, ncol
-CHARACTER(:), ALLOCATABLE :: ref0
-
-basisType0 = Input(default=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)
-ref0 = ""
-END PROCEDURE LagrangeCoeff_Triangle4
-
-!----------------------------------------------------------------------------
-! LagrangeCoeff_Triangle4
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeCoeff_Triangle4_
-
-SELECT CASE (basisType)
-
-CASE (Monomial)
- CALL LagrangeVandermonde_(order=order, xij=xij, elemType=Triangle, &
- ans=ans, nrow=nrow, ncol=ncol)
-
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
-
- CALL Dubiner_Triangle_(order=order, xij=xij, refTriangle=refTriangle, &
- ans=ans, nrow=nrow, ncol=ncol)
-
-CASE (Heirarchical)
-
- CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, &
- pe3=order, xij=xij, refTriangle=refTriangle, &
- ans=ans, nrow=nrow, ncol=ncol)
-END SELECT
-
-CALL GetInvMat(ans(1:nrow, 1:ncol))
-
-END PROCEDURE LagrangeCoeff_Triangle4_
-
-!----------------------------------------------------------------------------
-! LagrangeEvalAll_Triangle
-!----------------------------------------------------------------------------
-
-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))
-
-basisType0 = Input(default=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 = TRANSPOSE(coeff)
- ELSE
- coeff0 = TRANSPOSE(coeff)
- END IF
-
-ELSE
-
- CALL LagrangeCoeff_Triangle_(order=order, xij=xij, &
- basisType=basisType0, refTriangle=refTriangle, &
- ans=coeff0, nrow=nrow, ncol=ncol)
- coeff0 = TRANSPOSE(coeff0)
-
-END IF
-
-SELECT CASE (basisType0)
-
-CASE (Monomial)
-
- CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol)
-
- tdof = SIZE(xij, 2)
-
- DO ii = 1, tdof
- xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2)
- END DO
-
-CASE (Heirarchical)
-
- CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, &
- pe2=order, pe3=order, xij=RESHAPE(x, [2, 1]), &
- refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow)
-
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
-
- CALL Dubiner_Triangle_(order=order, xij=RESHAPE(x, [2, 1]), &
- refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol)
-
-END SELECT
-
-ans = MATMUL(coeff0, xx(1, :))
-END PROCEDURE LagrangeEvalAll_Triangle1
-
-!----------------------------------------------------------------------------
-! LagrangeEvalAll_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE LagrangeEvalAll_Triangle2
-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(SIZE(x, 2), SIZE(xij, 2))
-
-basisType0 = Input(default=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
-
- ELSE
-
- coeff0 = coeff
-
- END IF
-ELSE
-
- CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, &
- refTriangle=refTriangle, ans=coeff0, nrow=nrow, ncol=ncol)
-
-END IF
-
-SELECT CASE (basisType0)
-
-CASE (Monomial)
-
- CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol)
- tdof = SIZE(xij, 2)
-
- DO ii = 1, tdof
- xx(:, ii) = x(1, :)**degree(ii, 1) * x(2, :)**degree(ii, 2)
- END DO
-
-CASE (Heirarchical)
-
- CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, pe2=order, &
- pe3=order, xij=x, refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow)
-
-CASE (Jacobi, Orthogonal, Legendre, Lobatto, Ultraspherical)
-
- CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, &
- ans=xx, nrow=nrow, ncol=ncol)
-
-END SELECT
-
-ans = MATMUL(xx, coeff0)
-END PROCEDURE LagrangeEvalAll_Triangle2
-
-!----------------------------------------------------------------------------
-! LagrangeGradientEvalAll_Triangle
-!----------------------------------------------------------------------------
-
-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
-
-basisType0 = Input(default=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=s(1), ncol=s(2))
- END IF
-
- coeff0 = coeff
-ELSE
- CALL LagrangeCoeff_Triangle_(order=order, xij=xij, basisType=basisType0, &
- refTriangle=refTriangle, ans=coeff0, nrow=s(1), ncol=s(2))
-END IF
-
-SELECT CASE (basisType0)
-
-CASE (Monomial)
-
- CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=s(1), ncol=s(2))
-
- tdof = SIZE(xij, 2)
-
- DO ii = 1, tdof
- 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)
- END DO
-
-CASE (Heirarchical)
-
- 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)
-
- CALL OrthogonalBasisGradient_Triangle_(order=order, xij=x, &
- refTriangle=refTriangle, ans=xx, tsize1=s(1), tsize2=s(2), tsize3=s(3))
-
-END SELECT
-
-DO ii = 1, 2
- ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
- ans(:, :, ii) = MATMUL(xx(:, :, ii), coeff0)
-END DO
-
-END PROCEDURE LagrangeGradientEvalAll_Triangle1
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE LagrangeBasisMethods
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90
deleted file mode 100644
index 9e50e8c6a..000000000
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@Methods.F90
+++ /dev/null
@@ -1,549 +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(TriangleInterpolationUtility) Methods
-USE BaseMethod
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! GetTotalDOF_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE GetTotalDOF_Triangle
-ans = (order + 1) * (order + 2) / 2_I4B
-END PROCEDURE GetTotalDOF_Triangle
-
-!----------------------------------------------------------------------------
-! LagrangeInDOF_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE GetTotalInDOF_Triangle
-ans = (order - 1) * (order - 2) / 2_I4B
-END PROCEDURE GetTotalInDOF_Triangle
-
-!----------------------------------------------------------------------------
-! RefElemDomain_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE RefElemDomain_Triangle
-SELECT CASE (UpperCase(baseContinuity))
-CASE ("H1")
- SELECT CASE (UpperCase(baseInterpol))
- CASE ("LAGRANGEPOLYNOMIAL", "LAGRANGE", "LAGRANGEINTERPOLATION")
- ans = "UNIT"
- CASE ("SERENDIPITYPOLYNOMIAL", "SERENDIPITY", "SERENDIPITYINTERPOLATION")
- ans = "UNIT"
- CASE ("HERMITPOLYNOMIAL", "HERMIT", "HERMITINTERPOLATION")
- ans = "UNIT"
- CASE ( &
- & "HIERARCHICALPOLYNOMIAL", &
- & "HIERARCHY", &
- & "HEIRARCHICALPOLYNOMIAL", &
- & "HEIRARCHY", &
- & "HIERARCHYINTERPOLATION", &
- & "HEIRARCHYINTERPOLATION")
- ans = "BIUNIT"
- CASE ("ORTHOGONALPOLYNOMIAL", "ORTHOGONAL", "ORTHOGONALINTERPOLATION")
- ans = "BIUNIT"
- CASE DEFAULT
- CALL Errormsg(&
- & msg="No case found for given baseInterpol="//TRIM(baseInterpol), &
- & file=__FILE__, &
- & line=__LINE__,&
- & routine="RefElemDomain_Triangle()", &
- & 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)
-END SELECT
-END PROCEDURE RefElemDomain_Triangle
-
-!----------------------------------------------------------------------------
-! FacetConnectivity
-!----------------------------------------------------------------------------
-
-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")
- 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
-
-!----------------------------------------------------------------------------
-! EquidistancePoint_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE EquidistancePoint_Triangle
-INTEGER(I4B) :: nsd, n, ne, i1, i2
-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)
-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]
-END IF
-
-n = LagrangeDOF_Triangle(order=order)
-ALLOCATE (ans(nsd, n))
-ans = 0.0_DFP
-
-!! points on vertex
-ans(1:nsd, 1:3) = x(1:nsd, 1:3)
-
-!! points on edge
-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]))
- !!
-END IF
-
-!! 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
-END IF
-
-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
-
-IF (order .LT. 3_I4B) THEN
- ALLOCATE (ans(0, 0))
- RETURN
-END IF
-
-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)
-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]
-END IF
-
-n = LagrangeInDOF_Triangle(order=order)
-ALLOCATE (ans(nsd, 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))
- !!
-END IF
-
-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)
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
-
-CALL Reallocate(ans, nsd, N)
-CALL Reallocate(temp, 2, N)
-
-xi = 0.0_DFP
-eta = 0.0_DFP
-
-DO ii = 1, order + 1
- DO jj = 1, order + 2 - ii
- kk = order + 3 - ii - jj
- xi(ii, jj) = (1.0 + 2.0 * v(ii) - v(jj) - v(kk)) / 3.0_DFP
- eta(ii, jj) = (1.0 + 2.0 * v(jj) - v(ii) - v(kk)) / 3.0_DFP
- END DO
-END DO
-
-IF (layout .EQ. "VEFC") THEN
-
- CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N)
-
- IF (PRESENT(xij)) THEN
- ans = FromUnitTriangle2Triangle(xin=temp, &
- & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3))
- ELSE
- ans = temp
- 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
-
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
-
-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"
-
-rPoints = RecursiveNode2D(order=order, ipType=ipType, domain="UNIT", &
- & alpha=alpha, beta=beta, lambda=lambda)
-
-N = SIZE(rPoints, 2)
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2
-END IF
-
-CALL Reallocate(ans, nsd, N)
-
-!! convert from rPoints to xi and eta
-cnt = 0
-xi = 0.0_DFP
-eta = 0.0_DFP
-
-DO ii = 1, order + 1
- DO jj = 1, order + 2 - ii
- cnt = cnt + 1
- xi(ii, jj) = rPoints(1, cnt)
- eta(ii, jj) = rPoints(2, cnt)
- END DO
-END DO
-
-IF (layout .EQ. "VEFC") THEN
- CALL Reallocate(temp, 2, N)
- CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=N)
- IF (PRESENT(xij)) THEN
- ans = FromUnitTriangle2Triangle(xin=temp, &
- & x1=xij(:, 1), x2=xij(:, 2), x3=xij(:, 3))
- ELSE
- ans = temp
- 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
-
-IF (ALLOCATED(temp)) DEALLOCATE (temp)
-IF (ALLOCATED(rPoints)) DEALLOCATE (rPoints)
-END PROCEDURE Isaac_Triangle
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE IJ2VEFC_Triangle
-INTEGER(I4B) :: cnt, m, ii, jj, ll, llt, llr
-
-cnt = 0
-m = order
-llt = INT((m - 1) / 3)
-llr = MOD(m - 1, 3)
-DO ll = 0, llt
- !! v1
- cnt = cnt + 1
- ii = 1 + ll; jj = 1 + ll
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
- !! v2
- cnt = cnt + 1
- ii = m + 1 - 2 * ll; jj = 1 + ll
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
- !! v3
- cnt = cnt + 1
- ii = 1 + ll; jj = m + 1 - 2 * ll
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
- !! nodes on edge 12
- jj = ll + 1
- DO ii = 2 + ll, m - 2 * ll
- cnt = cnt + 1
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
- END DO
- !! nodes on edge 23
- DO jj = 2 + ll, m - 2 * ll
- cnt = cnt + 1
- ii = m - ll + 2 - jj
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
- END DO
- !! nodes on edge 31
- ii = ll + 1
- DO jj = m - 2 * ll, 2 + ll, -1
- cnt = cnt + 1
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
- END DO
- !! internal nodes
-END DO
-
-IF (llr .EQ. 2_I4B) THEN
- !! a internal point
- cnt = cnt + 1
- ll = llt + 1
- ii = 1 + ll; jj = 1 + ll
- temp(1, cnt) = xi(ii, jj)
- temp(2, cnt) = eta(ii, jj)
-END IF
-
-IF (cnt .NE. N) THEN
- CALL ErrorMsg( &
- & msg="cnt="//tostring(cnt)//" not equal to total DOF, N=" &
- & //tostring(N), &
- & file=__FILE__, &
- & routine="IJ2VEFC_Triangle()", &
- & line=__LINE__, &
- & unitno=stderr)
- RETURN
-END IF
-END PROCEDURE IJ2VEFC_Triangle
-
-!----------------------------------------------------------------------------
-! InterpolationPoint_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE InterpolationPoint_Triangle
-CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle"
-
-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)
-END SELECT
-END PROCEDURE InterpolationPoint_Triangle
-
-!----------------------------------------------------------------------------
-!
-!----------------------------------------------------------------------------
-
-END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90
deleted file mode 100644
index 26a49cb99..000000000
--- a/src/submodules/Polynomial/src/TriangleInterpolationUtility@QuadratureMethods.F90
+++ /dev/null
@@ -1,219 +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(TriangleInterpolationUtility) QuadratureMethods
-USE BaseMethod
-USE QuadraturePoint_Triangle_Solin, ONLY: QuadraturePointTriangleSolin, &
- QuadraturePointTriangleSolin_, &
- QuadratureNumberTriangleSolin
-IMPLICIT NONE
-CONTAINS
-
-!----------------------------------------------------------------------------
-! 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)
-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
-
-IF (PRESENT(xij)) THEN
- nsd = SIZE(xij, 1)
-ELSE
- nsd = 2_I4B
-END IF
-
-CALL Reallocate(ans, nsd + 1_I4B, SIZE(temp_q, 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_q)) DEALLOCATE (temp_q)
-IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
-
-END PROCEDURE TensorQuadraturePoint_Triangle2
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Triangle
-!----------------------------------------------------------------------------
-
-MODULE PROCEDURE QuadraturePoint_Triangle1
-INTEGER(I4B) :: nips(1), nsd, ii, jj
-REAL(DFP), ALLOCATABLE :: temp_t(:, :)
-LOGICAL(LGT) :: abool
-
-nips(1) = QuadratureNumberTriangleSolin(order=order)
-
-IF (nips(1) .LE. 0) THEN
- ans = TensorQuadraturepoint_Triangle(order=order, quadtype=quadtype, &
- reftriangle=reftriangle, xij=xij)
- RETURN
-END IF
-
-ALLOCATE (temp_t(3, nips(1)))
-CALL QuadraturePointTriangleSolin_(nips=nips, ans=temp_t, nrow=ii, &
- ncol=jj)
-
-nsd = 2_I4B
-abool = PRESENT(xij)
-IF (abool) nsd = SIZE(xij, 1)
-
-ii = nsd + 1
-ALLOCATE (ans(ii, jj))
-
-IF (abool) THEN
-
- 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")
-
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", &
- to="TRIANGLE", xij=xij)
-
- RETURN
-
-END IF
-
-abool = reftriangle(1:1) == "B" .OR. reftriangle(1:1) == "b"
-
-IF (abool) THEN
- ans(1:nsd, :) = FromUnitTriangle2BiUnitTriangle(xin=temp_t(1:2, :))
- ans(nsd + 1, :) = temp_t(3, :) * JacobianTriangle(from="UNIT", to="BIUNIT")
- RETURN
-END IF
-
-ans = temp_t
-
-IF (ALLOCATED(temp_t)) DEALLOCATE (temp_t)
-
-END PROCEDURE QuadraturePoint_Triangle1
-
-!----------------------------------------------------------------------------
-! QuadraturePoint_Triangle2
-!----------------------------------------------------------------------------
-
-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 SUBMODULE QuadratureMethods
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/deprecated/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90
deleted file mode 100644
index 353cf8485..000000000
--- a/src/submodules/Polynomial/src/deprecated/TriangleInterpolationUtility@Methods.F90
+++ /dev/null
@@ -1,376 +0,0 @@
-
-! PURE SUBROUTINE VertexBasis_Triangle2(Lo1, Lo2, ans)
-! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:)
-! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:)
-! !! coordinates on biunit square
-! REAL(DFP), INTENT(INOUT) :: ans(:, :)
-! ! ans(SIZE(Lo1, 1), 3)
-! !! ans(:,v1) basis function of vertex v1 at all points
-!
-! INTEGER(I4B) :: ii, tpoints
-!
-! tpoints = SIZE(ans, 1)
-!
-! DO CONCURRENT(ii=1:tpoints)
-! ans(ii, 1) = Lo1(ii, 0) * Lo2(ii, 0)
-! ans(ii, 2) = Lo1(ii, 1) * Lo2(ii, 0)
-! ans(ii, 3) = Lo1(ii, 1) * Lo2(ii, 1) + Lo1(ii, 0) * Lo2(ii, 1)
-! END DO
-!
-! END SUBROUTINE VertexBasis_Triangle2
-
-!----------------------------------------------------------------------------
-! EdgeBasis_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Eval basis on left, right edge of biunit Triangle (internal only)
-!
-!# Introduction
-!
-! Evaluate basis functions on left and right edge of biunit Triangle
-!
-! qe1 and qe2 should be greater than or equal to 2
-
-! PURE SUBROUTINE EdgeBasis_Triangle2(pe1, pe2, pe3, L1, L2, Lo1, &
-! & Lo2, ans)
-! INTEGER(I4B), INTENT(IN) :: pe1
-! !! order on left vertical edge (e1), should be greater than 1
-! INTEGER(I4B), INTENT(IN) :: pe2
-! !! order on right vertical edge(e2), should be greater than 1
-! INTEGER(I4B), INTENT(IN) :: pe3
-! !! order on right vertical edge(e3), should be greater than 1
-! REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
-! !! L1 and L2 are jacobian polynomials
-! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(INOUT) :: ans(:, :)
-! ! REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 - 3)
-!
-! INTEGER(I4B) :: maxP, k1, k2, a
-! REAL(DFP) :: asign
-!
-! maxP = MAX(pe1, pe2, pe3)
-! ! edge(1) = 1 -> 2
-! a = 0
-!
-! DO k1 = 2, pe1
-! ans(:, k1 - 1) = Lo1(:, 0) * Lo1(:, 1) * L1(:, k1 - 2) * (Lo2(:, 0)**k1)
-! END DO
-!
-! ! edge(2) = 2 -> 3
-! a = pe1 - 1
-! DO k2 = 2, pe2
-! ans(:, a + k2 - 1) = Lo1(:, 1) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2)
-! END DO
-!
-! ! edge(3) = 3 -> 1
-! a = pe1 - 1 + pe2 - 1
-! DO k2 = 2, pe3
-! asign = (-1.0_DFP)**(k2 - 2)
-! ans(:, a + k2 - 1) = asign * Lo1(:, 0) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2)
-! END DO
-!
-! END SUBROUTINE EdgeBasis_Triangle2
-
-!----------------------------------------------------------------------------
-! CellBasis_Triangle
-!----------------------------------------------------------------------------
-
-!> author: Vikas Sharma, Ph. D.
-! date: 28 Oct 2022
-! summary: Eval basis in the cell of biunit Triangle (internal only)
-!
-!# Introduction
-!
-! Evaluate basis functions in the cell of biunit Triangle
-
-! PURE SUBROUTINE CellBasis_Triangle2(order, L1, eta_ij, &
-! & Lo1, Lo2, ans)
-! INTEGER(I4B), INTENT(IN) :: order
-! !! order of approximation inside the cell, order>2
-! REAL(DFP), INTENT(IN) :: L1(1:, 0:)
-! !! lobatto polynomials
-! REAL(DFP), INTENT(IN) :: eta_ij(:, :)
-! !! coordinates on biunit square
-! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(INOUT) :: ans(:, :)
-! ! REAL(DFP) :: ans(SIZE(L1, 1), INT((order - 1) * (order - 2) / 2))
-!
-! ! FIXME: Remove these arrays, no allocation is our goal
-! REAL(DFP) :: P2(SIZE(eta_ij, 2), 0:order)
-! REAL(DFP) :: avec(SIZE(eta_ij, 2)), alpha, beta
-! INTEGER(I4B) :: k1, k2, max_k2, cnt
-!
-! alpha = 0.0_DFP
-! beta = 1.0_DFP
-! cnt = 0
-!
-! ! FIXME: Make this loop parallel
-!
-! DO k1 = 2, order - 1
-! avec = (Lo2(:, 0)**k1) * Lo2(:, 1) * Lo1(:, 0) * Lo1(:, 1)
-! alpha = 2.0_DFP * k1 - 1.0_DFP
-! max_k2 = MAX(order - k1 - 1, 0)
-! P2(:, 0:max_k2) = JacobiEvalAll(n=max_k2, x=eta_ij(2, :), &
-! & alpha=alpha, beta=beta)
-! DO k2 = 2, order - k1 + 1
-! cnt = cnt + 1
-! ans(:, cnt) = L1(:, k1 - 2) * avec * P2(:, k2 - 2)
-! END DO
-! END DO
-!
-! END SUBROUTINE CellBasis_Triangle2
-
-! PURE SUBROUTINE VertexBasisGradient_Triangle2(Lo1, Lo2, dLo1, dLo2, ans)
-! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:)
-! !! Lobatto polynomials evaluated at x1
-! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:)
-! !! Lobatto polynomials evaluated at x2
-! REAL(DFP), INTENT(IN) :: dLo1(1:, 0:)
-! !! Gradient of Lobatto polynomials at x1
-! REAL(DFP), INTENT(IN) :: dLo2(1:, 0:)
-! !! Gradient of Lobatto polynomials at x2
-! REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
-! ! REAL(DFP) :: ans(SIZE(Lo1, 1), 3, 2)
-! !! ans(:,v1) basis function of vertex v1 at all points
-!
-! ans(:, 1, 1) = dLo1(:, 0) * Lo2(:, 0)
-! ans(:, 1, 2) = Lo1(:, 0) * dLo2(:, 0)
-! ans(:, 2, 1) = dLo1(:, 1) * Lo2(:, 0)
-! ans(:, 2, 2) = Lo1(:, 1) * dLo2(:, 0)
-! ans(:, 3, 1) = dLo1(:, 1) * Lo2(:, 1) + dLo1(:, 0) * Lo2(:, 1)
-! ans(:, 3, 2) = Lo1(:, 1) * dLo2(:, 1) + Lo1(:, 0) * dLo2(:, 1)
-! END SUBROUTINE VertexBasisGradient_Triangle2
-
-! PURE SUBROUTINE EdgeBasisGradient_Triangle2(pe1, pe2, pe3, L1, L2, &
-! Lo1, Lo2, dL1, dL2, dLo1, dLo2, ans)
-! INTEGER(I4B), INTENT(IN) :: pe1
-! !! order on left vertical edge (e1), should be greater than 1
-! INTEGER(I4B), INTENT(IN) :: pe2
-! !! order on right vertical edge(e2), should be greater than 1
-! INTEGER(I4B), INTENT(IN) :: pe3
-! !! order on right vertical edge(e3), should be greater than 1
-! REAL(DFP), INTENT(IN) :: L1(1:, 0:), L2(1:, 0:)
-! !! L1 and L2 are jacobian polynomials
-! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(IN) :: dL1(1:, 0:), dL2(1:, 0:)
-! !! L1 and L2 are jacobian polynomials
-! REAL(DFP), INTENT(IN) :: dLo1(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(IN) :: dLo2(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
-! ! REAL(DFP) :: ans(SIZE(L1, 1), pe1 + pe2 + pe3 - 3, 2)
-!
-! INTEGER(I4B) :: maxP, k1, k2, a
-! REAL(DFP), DIMENSION(SIZE(Lo1, 1)) :: avec
-!
-! maxP = MAX(pe1, pe2, pe3)
-! ! edge(1)
-! a = 0
-!
-! DO k1 = 2, pe1
-! avec = dLo1(:, 0) * Lo1(:, 1) * L1(:, k1 - 2) &
-! & + Lo1(:, 0) * dLo1(:, 1) * L1(:, k1 - 2) &
-! & + Lo1(:, 0) * Lo1(:, 1) * dL1(:, k1 - 2)
-!
-! ans(:, k1 - 1, 1) = avec * (Lo2(:, 0)**k1)
-!
-! ans(:, k1 - 1, 2) = Lo1(:, 0) * Lo1(:, 1) &
-! & * L1(:, k1 - 2) &
-! & * REAL(k1, DFP) &
-! & * (Lo2(:, 0)**(k1 - 1)) &
-! & * dLo2(:, 0)
-! END DO
-!
-! ! edge(2)
-! a = pe1 - 1
-! DO k2 = 2, pe2
-! avec = dLo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) &
-! &+ Lo2(:, 0) * dLo2(:, 1) * L2(:, k2 - 2) &
-! &+ Lo2(:, 0) * Lo2(:, 1) * dL2(:, k2 - 2)
-! ans(:, a + k2 - 1, 1) = dLo1(:, 0) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2)
-! ans(:, a + k2 - 1, 2) = Lo1(:, 0) * avec
-! END DO
-!
-! ! edge(3)
-! a = pe1 - 1 + pe2 - 1
-! DO k2 = 2, pe3
-! avec = dLo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2) &
-! & + Lo2(:, 0) * dLo2(:, 1) * L2(:, k2 - 2) &
-! & + Lo2(:, 0) * Lo2(:, 1) * dL2(:, k2 - 2)
-! ans(:, a + k2 - 1, 1) = dLo1(:, 1) * Lo2(:, 0) * Lo2(:, 1) * L2(:, k2 - 2)
-! ans(:, a + k2 - 1, 2) = Lo1(:, 1) * avec
-! END DO
-! END SUBROUTINE EdgeBasisGradient_Triangle2
-
-! PURE SUBROUTINE CellBasisGradient_Triangle2(order, eta_ij, L1, Lo1, &
-! Lo2, dL1, dLo1, dLo2, ans)
-! INTEGER(I4B), INTENT(IN) :: order
-! !! order of approximation inside the cell, order>2
-! REAL(DFP), INTENT(IN) :: eta_ij(:, :)
-! !! coordinates on biunit square
-! REAL(DFP), INTENT(IN) :: L1(1:, 0:)
-! !! lobatto polynomials
-! REAL(DFP), INTENT(IN) :: Lo1(1:, 0:)
-! !! coordinates on biunit square domain
-! REAL(DFP), INTENT(IN) :: Lo2(1:, 0:)
-! !!
-! REAL(DFP), INTENT(IN) :: dL1(1:, 0:)
-! !! lobatto polynomials
-! REAL(DFP), INTENT(IN) :: dLo1(1:, 0:)
-! !!
-! REAL(DFP), INTENT(IN) :: dLo2(1:, 0:)
-! !!
-! REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
-! ! REAL(DFP) :: ans(SIZE(L1, 1), INT((order - 1) * (order - 2) / 2), 2)
-!
-! REAL(DFP) :: P2(SIZE(eta_ij, 2), 0:order)
-! REAL(DFP) :: dP2(SIZE(eta_ij, 2), 0:order)
-!
-! REAL(DFP) :: temp(SIZE(eta_ij, 2), 13)
-!
-! REAL(DFP) :: alpha, beta
-! INTEGER(I4B) :: k1, k2, max_k2, cnt
-!
-! alpha = 0.0_DFP
-! beta = 1.0_DFP
-! cnt = 0
-! temp(:, 5) = dLo1(:, 0) * Lo1(:, 1)
-! temp(:, 6) = Lo1(:, 0) * dLo1(:, 1)
-! temp(:, 7) = Lo1(:, 0) * Lo1(:, 1)
-! temp(:, 9) = dLo2(:, 0) * Lo2(:, 1)
-! temp(:, 12) = Lo2(:, 0) * Lo2(:, 1)
-! temp(:, 13) = Lo2(:, 0) * dLo2(:, 1)
-!
-! DO k1 = 2, order - 1
-! alpha = 2.0_DFP * k1 - 1.0_DFP
-! max_k2 = MAX(order - k1 - 1, 0)
-! P2(:, 0:max_k2) = JacobiEvalAll(n=max_k2, x=eta_ij(2, :), &
-! & alpha=alpha, beta=beta)
-! dP2(:, 0:max_k2) = JacobiGradientEvalAll(n=max_k2, x=eta_ij(2, :), &
-! & alpha=alpha, beta=beta)
-!
-! temp(:, 1) = (temp(:, 5) + temp(:, 6)) * L1(:, k1 - 2) &
-! & + temp(:, 7) * dL1(:, k1 - 2)
-! temp(:, 11) = Lo2(:, 0)**(k1 - 1)
-! temp(:, 2) = temp(:, 11) * temp(:, 12)
-! temp(:, 3) = temp(:, 7) * L1(:, k1 - 2)
-!
-! temp(:, 10) = REAL(k1, dfp) * temp(:, 9) + temp(:, 13)
-! temp(:, 8) = temp(:, 11) * temp(:, 10)
-!
-! DO k2 = 2, order - k1 + 1
-! cnt = cnt + 1
-! temp(:, 4) = temp(:, 8) * P2(:, k2 - 2) + temp(:, 2) * dP2(:, k2 - 2)
-!
-! ans(:, cnt, 1) = temp(:, 1) * temp(:, 2) * P2(:, k2 - 2)
-! ans(:, cnt, 2) = temp(:, 3) * temp(:, 4)
-! END DO
-!
-! END DO
-!
-! END SUBROUTINE CellBasisGradient_Triangle2
-
-! 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
-! 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
-! 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) :: ans( &
-! & SIZE(xij, 2), &
-! & pe1 + pe2 + pe3 + INT((order - 1) * (order - 2) / 2), 2)
-! !!
-!
-! CHARACTER(20) :: layout
-! REAL(DFP) :: x(SIZE(xij, 1), SIZE(xij, 2))
-! REAL(DFP) :: L1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order))
-! REAL(DFP) :: L2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order))
-! REAL(DFP) :: dL1(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order))
-! REAL(DFP) :: dL2(SIZE(xij, 2), 0:MAX(pe1, pe2, pe3, order))
-! REAL(DFP) :: Lo1(SIZE(xij, 2), 0:1)
-! REAL(DFP) :: Lo2(SIZE(xij, 2), 0:1)
-! REAL(DFP) :: dLo1(SIZE(xij, 2), 0:1)
-! REAL(DFP) :: dLo2(SIZE(xij, 2), 0:1)
-!
-! INTEGER(I4B) :: maxP, a, b
-!
-! layout = TRIM(UpperCase(refTriangle))
-!
-! IF (layout .EQ. "BIUNIT") THEN
-! x = FromBiUnitTriangle2BiUnitSqr(xin=xij)
-! ELSE
-! x = FromUnitTriangle2BiUnitSqr(xin=xij)
-! END IF
-!
-! Lo1(:, 0) = 0.5_DFP * (1.0 - x(1, :))
-! Lo1(:, 1) = 0.5_DFP * (1.0 + x(1, :))
-! Lo2(:, 0) = 0.5_DFP * (1.0 - x(2, :))
-! Lo2(:, 1) = 0.5_DFP * (1.0 + x(2, :))
-! dLo1(:, 0) = -0.5_DFP
-! dLo1(:, 1) = 0.5_DFP
-! dLo2(:, 0) = -0.5_DFP
-! dLo2(:, 1) = 0.5_DFP
-!
-! !! Vertex basis function
-! ! ans = 0.0_DFP
-! CALL VertexBasisGradient_Triangle2(Lo1=Lo1, Lo2=Lo2, dLo1=dLo1, dLo2=dLo2, &
-! ans=ans(:, 1:3, 1:2))
-!
-! maxP = MAX(pe1, pe2, pe3, order)
-! L1 = JacobiEvalAll(n=maxP, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP)
-! L2 = JacobiEvalAll(n=maxP, x=x(2, :), alpha=1.0_DFP, beta=1.0_DFP)
-! dL1 = JacobiGradientEvalAll(n=maxP, x=x(1, :), alpha=1.0_DFP, beta=1.0_DFP)
-! dL2 = JacobiGradientEvalAll(n=maxP, x=x(2, :), alpha=1.0_DFP, beta=1.0_DFP)
-!
-! !! Edge basis function
-! b = 3
-! IF (pe1 .GE. 2_I4B .OR. pe2 .GE. 2_I4B .OR. pe3 .GE. 2_I4B) THEN
-! a = b + 1
-! b = a - 1 + pe1 + pe2 + pe3 - 3 !!4+qe1 + qe2 - 2
-! CALL EdgeBasisGradient_Triangle2(pe1=pe1, pe2=pe2, pe3=pe3, L1=L1, L2=L2, &
-! Lo1=Lo1, Lo2=Lo2, dL1=dL1, dL2=dL2, dLo1=dLo1, dLo2=dLo2, &
-! ans=ans(:, a:b, 1:2))
-! END IF
-!
-! !! Cell basis function
-! IF (order .GT. 2_I4B) THEN
-! a = b + 1
-! b = a - 1 + INT((order - 1) * (order - 2) / 2)
-! CALL CellBasisGradient_Triangle2( &
-! & order=order, &
-! & L1=L1, &
-! & Lo1=Lo1, &
-! & Lo2=Lo2, &
-! & dL1=dL1, &
-! & dLo1=dLo1, &
-! & dLo2=dLo2, &
-! & eta_ij=x, ans=ans(:, a:b, 1:2))
-! END IF
-! END FUNCTION HeirarchicalBasisGradient_Triangle1
diff --git a/src/submodules/Prism/CMakeLists.txt b/src/submodules/Prism/CMakeLists.txt
new file mode 100644
index 000000000..d94c6cc5f
--- /dev/null
+++ b/src/submodules/Prism/CMakeLists.txt
@@ -0,0 +1,21 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME} PRIVATE ${src_path}/ReferencePrism_Method@Methods.F90
+ ${src_path}/PrismInterpolationUtility@Methods.F90)
diff --git a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90 b/src/submodules/Prism/src/PrismInterpolationUtility@Methods.F90
similarity index 65%
rename from src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90
rename to src/submodules/Prism/src/PrismInterpolationUtility@Methods.F90
index 89c49dfe6..921320e47 100644
--- a/src/submodules/Polynomial/src/PrismInterpolationUtility@Methods.F90
+++ b/src/submodules/Prism/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/Geometry/src/ReferencePrism_Method@Methods.F90 b/src/submodules/Prism/src/ReferencePrism_Method@Methods.F90
similarity index 95%
rename from src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90
rename to src/submodules/Prism/src/ReferencePrism_Method@Methods.F90
index 281bc250e..7f325ee24 100644
--- a/src/submodules/Geometry/src/ReferencePrism_Method@Methods.F90
+++ b/src/submodules/Prism/src/ReferencePrism_Method@Methods.F90
@@ -377,13 +377,29 @@
! GetFaceElemType_Prism
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Prism
+MODULE PROCEDURE GetFaceElemType_Prism1
IF (PRESENT(faceElemType)) &
faceElemType(1:5) = [Triangle3, Quadrangle4, Quadrangle4, Quadrangle4, &
Triangle3]
IF (PRESENT(tFaceNodes)) tFaceNodes(1:5) = [3, 4, 4, 4, 3]
-END PROCEDURE GetFaceElemType_Prism
+END PROCEDURE GetFaceElemType_Prism1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Prism
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Prism2
+
+SELECT CASE (localFaceNumber)
+CASE (1, 5)
+ faceElemType = Triangle3
+ tFaceNodes = 3
+CASE DEFAULT
+ faceElemType = Quadrangle4
+ tFaceNodes = 4
+END SELECT
+END PROCEDURE GetFaceElemType_Prism2
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Projection/CMakeLists.txt b/src/submodules/Projection/CMakeLists.txt
new file mode 100644
index 000000000..218b15a47
--- /dev/null
+++ b/src/submodules/Projection/CMakeLists.txt
@@ -0,0 +1,20 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(${PROJECT_NAME}
+ PRIVATE ${src_path}/Projection_Method@L2Methods.F90)
diff --git a/src/submodules/Projection/src/Projection_Method@L2Methods.F90 b/src/submodules/Projection/src/Projection_Method@L2Methods.F90
new file mode 100644
index 000000000..c0f92d529
--- /dev/null
+++ b/src/submodules/Projection/src/Projection_Method@L2Methods.F90
@@ -0,0 +1,203 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(Projection_Method) L2Methods
+USE BaseType, ONLY: math => TypeMathOpt
+USE InputUtility, ONLY: Input
+USE Display_Method, ONLY: ToString
+USE Display_Method, ONLY: Display
+USE MassMatrix_Method, ONLY: MassMatrix_
+USE ForceVector_Method, ONLY: ForceVector_
+USE Lapack_Method, ONLY: GetLU, LUSolve, GetInvMat
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = "Projection_Method@L2Methods"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValueFromQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature1()"
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: n1
+#endif
+
+INTEGER(I4B) :: info, nrow, ncol
+
+#ifdef DEBUG_VER
+n1 = SIZE(func)
+isok = n1 .GE. elemsd%nips
+CALL AssertError1( &
+ isok, myName, modName, __LINE__, &
+ 'Size of func='//ToString(n1)//' is lesser than elemsd%nips='// &
+ ToString(elemsd%nips))
+#endif
+
+CALL MassMatrix_( &
+ N=elemsd%N, M=elemsd%N, js=elemsd%js, ws=elemsd%ws, &
+ thickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, &
+ nns2=elemsd%nns, skipVertices=skipVertices, tVertices=tVertices, &
+ ans=massMat, nrow=nrow, ncol=ncol)
+
+CALL ForceVector_( &
+ N=elemsd%N, js=elemsd%js, ws=elemsd%ws, thickness=elemsd%thickness, &
+ nips=elemsd%nips, nns=elemsd%nns, skipVertices=skipVertices, &
+ tVertices=tVertices, ans=ans, tsize=tsize, c=func)
+
+CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info)
+
+CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), &
+ IPIV=ipiv(1:tsize), info=info)
+END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature1
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValueFromQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature2()"
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: n1
+#endif
+
+INTEGER(I4B) :: info, nrow, ncol
+
+#ifdef DEBUG_VER
+n1 = SIZE(func, 1)
+isok = n1 .GE. elemsd%nips
+CALL AssertError1( &
+ isok, myName, modName, __LINE__, &
+ 'Size of func='//ToString(n1)//' is lesser than elemsd%nips='// &
+ ToString(elemsd%nips))
+#endif
+
+#ifdef DEBUG_VER
+n1 = SIZE(func, 2)
+isok = n1 .GE. timeElemsd%nips
+CALL AssertError1( &
+ isok, myName, modName, __LINE__, &
+ 'Size of func='//ToString(n1)//' is lesser than timeElemsd%nips='// &
+ ToString(timeElemsd%nips))
+#endif
+
+CALL MassMatrix_( &
+ spaceN=elemsd%N, spaceM=elemsd%N, js=elemsd%js, ws=elemsd%ws, &
+ spaceThickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, &
+ nns2=elemsd%nns, skipVertices=skipVertices, tSpaceVertices=tSpaceVertices, &
+ timeN=timeElemsd%N, timeM=timeElemsd%N, jt=timeElemsd%js, &
+ wt=timeElemsd%ws, timeThickness=timeElemsd%thickness, &
+ nipt=timeElemsd%nips, nnt1=timeElemsd%nns, nnt2=timeElemsd%nns, &
+ tTimeVertices=tTimeVertices, ans=massMat, nrow=nrow, ncol=ncol)
+
+CALL ForceVector_( &
+ spaceN=elemsd%N, js=elemsd%js, ws=elemsd%ws, &
+ spaceThickness=elemsd%thickness, nips=elemsd%nips, nns=elemsd%nns, &
+ timeN=timeElemsd%N, jt=timeElemsd%js, wt=timeElemsd%ws, &
+ timeThickness=timeElemsd%thickness, nipt=timeElemsd%nips, &
+ nnt=timeElemsd%nns, skipVertices=skipVertices, &
+ tSpaceVertices=tSpaceVertices, tTimeVertices=tTimeVertices, &
+ c=func, ans=ans, tsize=tsize)
+
+CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info)
+
+CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), &
+ IPIV=ipiv(1:tsize), info=info)
+
+END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature2
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValueFromQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature3
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature3()"
+#endif
+
+INTEGER(I4B) :: info, nrow, ncol
+
+CALL MassMatrix_( &
+ N=elemsd%N, M=elemsd%N, js=elemsd%js, ws=elemsd%ws, &
+ thickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, &
+ nns2=elemsd%nns, skipVertices=skipVertices, tVertices=tVertices, &
+ ans=massMat, nrow=nrow, ncol=ncol)
+
+CALL ForceVector_( &
+ N=elemsd%N, js=elemsd%js, ws=elemsd%ws, thickness=elemsd%thickness, &
+ nips=elemsd%nips, nns=elemsd%nns, skipVertices=skipVertices, &
+ tVertices=tVertices, ans=ans, tsize=tsize)
+
+CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info)
+
+CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), &
+ IPIV=ipiv(1:tsize), info=info)
+END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature3
+
+!----------------------------------------------------------------------------
+! GetL2ProjectionDOFValueFromQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature4
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "obj_GetFacetDOFValueFromQuadrature4()"
+#endif
+
+INTEGER(I4B) :: info, nrow, ncol
+
+
+CALL MassMatrix_( &
+ spaceN=elemsd%N, spaceM=elemsd%N, js=elemsd%js, ws=elemsd%ws, &
+ spaceThickness=elemsd%thickness, nips=elemsd%nips, nns1=elemsd%nns, &
+ nns2=elemsd%nns, skipVertices=skipVertices, tSpaceVertices=tSpaceVertices, &
+ timeN=timeElemsd%N, timeM=timeElemsd%N, jt=timeElemsd%js, &
+ wt=timeElemsd%ws, timeThickness=timeElemsd%thickness, &
+ nipt=timeElemsd%nips, nnt1=timeElemsd%nns, nnt2=timeElemsd%nns, &
+ tTimeVertices=tTimeVertices, ans=massMat, nrow=nrow, ncol=ncol)
+
+CALL ForceVector_( &
+ spaceN=elemsd%N, js=elemsd%js, ws=elemsd%ws, &
+ spaceThickness=elemsd%thickness, nips=elemsd%nips, nns=elemsd%nns, &
+ timeN=timeElemsd%N, jt=timeElemsd%js, wt=timeElemsd%ws, &
+ timeThickness=timeElemsd%thickness, nipt=timeElemsd%nips, &
+ nnt=timeElemsd%nns, skipVertices=skipVertices, &
+ tSpaceVertices=tSpaceVertices, tTimeVertices=tTimeVertices, &
+ ans=ans, tsize=tsize)
+
+CALL GetLU(A=massMat(1:nrow, 1:ncol), IPIV=ipiv(1:tsize), info=info)
+
+CALL LUSolve(A=massMat(1:nrow, 1:ncol), B=ans(1:tsize), &
+ IPIV=ipiv(1:tsize), info=info)
+
+END PROCEDURE obj_GetL2ProjectionDOFValueFromQuadrature4
+
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE L2Methods
+
diff --git a/src/submodules/Pyramid/CMakeLists.txt b/src/submodules/Pyramid/CMakeLists.txt
new file mode 100644
index 000000000..a1ab61058
--- /dev/null
+++ b/src/submodules/Pyramid/CMakeLists.txt
@@ -0,0 +1,22 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferencePyramid_Method@Methods.F90
+ PRIVATE ${src_path}/PyramidInterpolationUtility@Methods.F90)
diff --git a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90 b/src/submodules/Pyramid/src/PyramidInterpolationUtility@Methods.F90
similarity index 64%
rename from src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90
rename to src/submodules/Pyramid/src/PyramidInterpolationUtility@Methods.F90
index ccbdb15b7..93585e06e 100644
--- a/src/submodules/Polynomial/src/PyramidInterpolationUtility@Methods.F90
+++ b/src/submodules/Pyramid/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/Geometry/src/ReferencePyramid_Method@Methods.F90 b/src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90
similarity index 95%
rename from src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90
rename to src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90
index d2638525f..14302d8de 100644
--- a/src/submodules/Geometry/src/ReferencePyramid_Method@Methods.F90
+++ b/src/submodules/Pyramid/src/ReferencePyramid_Method@Methods.F90
@@ -352,14 +352,29 @@
! GetFaceElemType_Pyramid
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Pyramid
-
+MODULE PROCEDURE GetFaceElemType_Pyramid1
IF (PRESENT(faceElemType)) &
faceElemType(1:5) = [Quadrangle4, Triangle3, Triangle3, Triangle3, &
Triangle3]
IF (PRESENT(tFaceNodes)) tFaceNodes(1:5) = [4, 3, 3, 3, 3]
-END PROCEDURE GetFaceElemType_Pyramid
+END PROCEDURE GetFaceElemType_Pyramid1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Pyramid
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Pyramid2
+
+SELECT CASE (localFaceNumber)
+CASE (1)
+ faceElemType = Quadrangle4
+ tFaceNodes = 4
+CASE DEFAULT
+ faceElemType = Triangle3
+ tFaceNodes = 3
+END SELECT
+END PROCEDURE GetFaceElemType_Pyramid2
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Quadrangle/CMakeLists.txt b/src/submodules/Quadrangle/CMakeLists.txt
new file mode 100644
index 000000000..6b199a483
--- /dev/null
+++ b/src/submodules/Quadrangle/CMakeLists.txt
@@ -0,0 +1,29 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferenceQuadrangle_Method@Methods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@Methods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@DOFMethods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@LagrangeMethods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@TensorProdMethods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@HierarchicalMethods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@DubinerMethods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@InterpolationPointMethods.F90
+ PRIVATE ${src_path}/QuadrangleInterpolationUtility@QuadratureMethods.F90)
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90
similarity index 54%
rename from src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90
rename to src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90
index a23c6c040..72a513a69 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@EqualMethods.F90
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DOFMethods.F90
@@ -13,64 +13,37 @@
!
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
-!
-SUBMODULE(FEVariable_Method) EqualMethods
-USE BaseMethod
+SUBMODULE(QuadrangleInterpolationUtility) DOFMethods
IMPLICIT NONE
CONTAINS
!----------------------------------------------------------------------------
-! NORM2
+! GetTotalDOF_Quadrangle
!----------------------------------------------------------------------------
-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.
-!!
-END PROCEDURE fevar_isequal
+MODULE PROCEDURE GetTotalDOF_Quadrangle
+ans = (order + 1)**2
+END PROCEDURE GetTotalDOF_Quadrangle
!----------------------------------------------------------------------------
-! NORM2
+! GetTotalInDOF_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE fevar_notEqual
-!! Internal variable
-ans = .FALSE.
-IF( .NOT. ALL(obj1%val .APPROXEQ. obj2%val) ) THEN
- ans = .TRUE.
- RETURN
-END IF
-!!
-IF( obj1%defineon .ne. obj2%defineon ) THEN
- ans = .TRUE.
- RETURN
-END IF
-!!
-IF( obj1%rank .ne. obj2%rank ) THEN
- ans = .TRUE.
- RETURN
-END IF
-!!
-IF( obj1%varType .ne. obj2%varType ) THEN
- ans = .TRUE.
- RETURN
-END IF
-!!
-IF( ANY(obj1%s .NE. obj2%s) ) THEN
- ans = .TRUE.
- RETURN
-END IF
-!!
-END PROCEDURE fevar_notEqual
+MODULE PROCEDURE GetTotalInDOF_Quadrangle1
+ans = (order - 1)**2
+END PROCEDURE GetTotalInDOF_Quadrangle1
!----------------------------------------------------------------------------
-!
+! GetTotalInDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalInDOF_Quadrangle2
+ans = (p - 1) * (q - 1)
+END PROCEDURE GetTotalInDOF_Quadrangle2
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Quadrangle3
!----------------------------------------------------------------------------
-END SUBMODULE EqualMethods
+END SUBMODULE DOFMethods
diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90
new file mode 100644
index 000000000..2ac67d856
--- /dev/null
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@DubinerMethods.F90
@@ -0,0 +1,193 @@
+! 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(QuadrangleInterpolationUtility) DubinerMethods
+USE LegendrePolynomialUtility, ONLY: LegendreEvalAll_, &
+ LegendreGradientEvalAll_
+USE JacobiPolynomialUtility, ONLY: JacobiEvalAll_, &
+ JacobiGradientEvalAll_
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Dubiner_Quadrangle1
+INTEGER(I4B) :: nrow, ncol
+CALL Dubiner_Quadrangle1_(xij=xij, order=order, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE Dubiner_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Dubiner_Quadrangle1_
+REAL(DFP) :: P1(SIZE(xij, 2), order + 1), P2(SIZE(xij, 2), order + 1), &
+ temp(SIZE(xij, 2), 3)
+REAL(DFP) :: alpha, beta
+INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii
+
+nrow = SIZE(xij, 2)
+ncol = (order + 1) * (order + 2) / 2
+
+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
+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
+
+ !! 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)
+ 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
+
+ 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
+
+END PROCEDURE Dubiner_Quadrangle1_
+
+!----------------------------------------------------------------------------
+! DubinerGradient_Quadrangle1
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE DubinerGradient_Quadrangle1
+INTEGER(I4B) :: s(3)
+CALL DubinerGradient_Quadrangle1_(xij=xij, order=order, ans=ans, &
+ tsize1=s(1), tsize2=s(2), tsize3=s(3))
+END PROCEDURE DubinerGradient_Quadrangle1
+
+!----------------------------------------------------------------------------
+! DubinerGradient_Quadrangle1
+!----------------------------------------------------------------------------
+
+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, areal
+INTEGER(I4B) :: k1, k2, max_k2, cnt, indx(2), ii
+
+tsize1 = SIZE(xij, 2)
+tsize2 = (order + 1) * (order + 2) / 2
+tsize3 = 2
+
+x = xij(1, :)
+y = xij(2, :)
+
+! 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)
+alpha = 1.0_DFP
+beta = 0.0_DFP
+cnt = 0
+
+DO k1 = 0, order
+ bvec = x**(MAX(k1 - 1_I4B, 0_I4B))
+ avec = x * bvec
+ alpha = 2.0_DFP * k1 + 1.0_DFP
+
+ max_k2 = order - k1
+
+ CALL JacobiEvalAll_(n=max_k2, x=y, alpha=alpha, beta=beta, &
+ ans=P2, nrow=indx(1), ncol=indx(2))
+
+ 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
+
+ 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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Dubiner_Quadrangle2
+INTEGER(I4B) :: nrow, ncol
+CALL Dubiner_Quadrangle2_(x=x, y=y, order=order, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE Dubiner_Quadrangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Dubiner_Quadrangle2_
+REAL(DFP) :: xij(2, SIZE(x) * SIZE(y))
+INTEGER(I4B) :: ii, jj, cnt
+
+xij = 0.0_DFP
+cnt = 0
+DO ii = 1, SIZE(x)
+ DO jj = 1, SIZE(y)
+ cnt = cnt + 1
+ xij(1, cnt) = x(ii)
+ xij(2, cnt) = y(jj)
+ END DO
+END DO
+CALL Dubiner_Quadrangle1_(order=order, xij=xij, ans=ans, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE Dubiner_Quadrangle2_
+
+END SUBMODULE DubinerMethods
diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90
new file mode 100644
index 000000000..81b2f7e74
--- /dev/null
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@HierarchicalMethods.F90
@@ -0,0 +1,953 @@
+! 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(QuadrangleInterpolationUtility) HierarchicalMethods
+USE LobattoPolynomialUtility, ONLY: LobattoEvalAll_, &
+ LobattoGradientEvalAll_
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetHierarchicalDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetHierarchicalDOF_Quadrangle
+ans = 0
+
+SELECT CASE (opt)
+
+CASE ("v", "V")
+ ans = 4
+
+CASE ("e", "E")
+ ans = qe1 + qe2 + pe3 + pe4 - 4
+
+CASE ("c", "C")
+ ans = (pb - 1) * (qb - 1)
+
+CASE DEFAULT
+ ans = qe1 + qe2 + pe3 + pe4 + (pb - 1) * (qb - 1)
+
+END SELECT
+END PROCEDURE GetHierarchicalDOF_Quadrangle
+
+!----------------------------------------------------------------------------
+! VertexBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VertexBasis_Quadrangle1
+INTEGER(I4B) :: nrow, ncol
+CALL VertexBasis_Quadrangle1_(x=x, y=y, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE VertexBasis_Quadrangle1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! VertexBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VertexBasis_Quadrangle2
+INTEGER(I4B) :: nrow, ncol
+CALL VertexBasis_Quadrangle2_(xij=xij, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE VertexBasis_Quadrangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VertexBasis_Quadrangle2_
+CALL VertexBasis_Quadrangle1_(x=xij(1, :), y=xij(2, :), ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE VertexBasis_Quadrangle2_
+
+!----------------------------------------------------------------------------
+! VertexBasisGradient_Quadrangle2_
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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_
+
+!----------------------------------------------------------------------------
+! VerticalEdgeBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE VerticalEdgeBasis_Quadrangle
+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(:, :)
+
+nrow = SIZE(x)
+ncol = 0
+
+maxQ = MAX(qe1, qe2)
+aint = SIZE(y)
+ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ))
+
+CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint)
+CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint)
+
+! Left vertical
+CALL LeftVerticalEdgeBasis_Quadrangle_( &
+ order=qe1, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, &
+ orient=orient, offset=ncol)
+ncol = ncol + aint
+
+! Right vertical
+CALL RightVerticalEdgeBasis_Quadrangle_( &
+ order=qe2, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, &
+ orient=orient, offset=ncol)
+ncol = ncol + aint
+
+DEALLOCATE (L2, L1)
+END PROCEDURE VerticalEdgeBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! LeftVerticalEdgeBasis_Quadrangle_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE LeftVerticalEdgeBasis_Quadrangle_( &
+ order, L1, L2, ans, nrow, ncol, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order on left vertical edge (e1), 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) :: orient
+ !! orientation of left and right vertical edge
+ !! it can be 1 or -1
+ INTEGER(I4B), INTENT(IN) :: offset
+ !! data will we written in ans from offset + 1
+ !! If you want to start from ans(:, 1) then set offset = 0
+
+ INTEGER(I4B) :: k2, ii
+ REAL(DFP) :: o1
+
+ o1 = REAL(-orient, kind=DFP)
+ ! Here we multiply by -1 because the left edge is oriented downwards
+ ! in master element
+
+ nrow = SIZE(L1, 1) !! Number of points of evaluation
+ ncol = order - 1 !! these are internal DOFs on edge
+
+ DO CONCURRENT(k2=2:order, ii=1:nrow)
+ ans(ii, offset + k2 - 1) = (o1**k2) * L1(ii, 0) * L2(ii, k2)
+ END DO
+
+END SUBROUTINE LeftVerticalEdgeBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! RightVerticalEdgeBasis_Quadrangle_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE RightVerticalEdgeBasis_Quadrangle_( &
+ order, L1, L2, ans, nrow, ncol, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order on left vertical edge (e1), 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) :: orient
+ !! orientation of left and right vertical edge
+ !! it can be 1 or -1
+ INTEGER(I4B), INTENT(IN) :: offset
+ !! data will we written in ans from offset + 1
+ !! If you want to start from ans(:, 1) then set offset = 0
+
+ INTEGER(I4B) :: k2, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(orient, kind=DFP)
+
+ nrow = SIZE(L1, 1) !! number of points of evaluation
+ ncol = order - 1 !! these are internal dof on edge
+
+ !! right vertical
+ DO CONCURRENT(k2=2:order, ii=1:nrow)
+ ans(ii, offset + k2 - 1) = (mysign**k2) * L1(ii, 1) * L2(ii, k2)
+ END DO
+
+END SUBROUTINE RightVerticalEdgeBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! LeftVerticalEdgeBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Returns the vertex basis functions on biunit quadrangle
+
+PURE SUBROUTINE LeftVerticalEdgeBasisGradient_Quadrangle_( &
+ order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order on left vertical edge (e1), 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=order-1
+ !! dim3= 2
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! range of data written to ans
+ INTEGER(I4B), INTENT(IN) :: orient
+ !! orientation fo left and write vertical edge
+ !! it can be 1 or -1
+ INTEGER(I4B), INTENT(IN) :: offset
+
+ INTEGER(I4B) :: k2, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(-orient, kind=DFP)
+ ! Here we multiply by -1 because the left edge is oriented downwards &
+ ! in master element
+
+ dim1 = SIZE(L1, 1)
+ dim2 = order - 1
+ dim3 = 2
+
+ DO CONCURRENT(k2=2:order, ii=1:dim1)
+ ans(ii, offset + k2 - 1, 1) = (mysign**k2) * dL1(ii, 0) * L2(ii, k2)
+ ans(ii, offset + k2 - 1, 2) = (mysign**k2) * L1(ii, 0) * dL2(ii, k2)
+ END DO
+
+END SUBROUTINE LeftVerticalEdgeBasisGradient_Quadrangle_
+
+!----------------------------------------------------------------------------
+! VerticalEdgeBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Returns the vertex basis functions on biunit quadrangle
+
+PURE SUBROUTINE RightVerticalEdgeBasisGradient_Quadrangle_( &
+ order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! 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=order-1
+ !! dim3= 2
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+ !! range of data written to ans
+ INTEGER(I4B), INTENT(IN) :: orient
+ !! orientation fo left and write vertical edge
+ !! it can be 1 or -1
+ INTEGER(I4B), INTENT(IN) :: offset
+
+ INTEGER(I4B) :: k2, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(orient, kind=DFP)
+
+ dim1 = SIZE(L1, 1)
+ dim2 = order - 1
+ dim3 = 2
+
+ ! Right vertical
+ DO CONCURRENT(k2=2:order, ii=1:dim1)
+ ans(ii, offset + k2 - 1, 1) = (mysign**k2) * dL1(ii, 1) * L2(ii, k2)
+ ans(ii, offset + k2 - 1, 2) = (mysign**k2) * L1(ii, 1) * dL2(ii, k2)
+ END DO
+END SUBROUTINE RightVerticalEdgeBasisGradient_Quadrangle_
+
+!----------------------------------------------------------------------------
+! HorizontalEdgeBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HorizontalEdgeBasis_Quadrangle
+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)
+
+nrow = SIZE(x)
+ncol = 0
+aint = SIZE(y)
+
+ALLOCATE (L1(1:nrow, 0:maxP), L2(1:aint, 0:maxQ))
+
+CALL LobattoEvalAll_(n=maxP, x=x, ans=L1, nrow=aint, ncol=bint)
+CALL LobattoEvalAll_(n=maxQ, x=y, ans=L2, nrow=aint, ncol=bint)
+
+! Bottom Horizontal
+CALL BottomHorizontalEdgeBasis_Quadrangle_( &
+ order=pe3, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, orient=orient, &
+ offset=ncol)
+ncol = ncol + aint
+
+! Top Horizontal
+CALL TopHorizontalEdgeBasis_Quadrangle_( &
+ order=pe4, L1=L1, L2=L2, ans=ans, nrow=nrow, ncol=aint, orient=orient, &
+ offset=ncol)
+ncol = ncol + aint
+
+DEALLOCATE (L1, L2)
+
+END PROCEDURE HorizontalEdgeBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! BottomHorizontalEdgeBasis_Quadrangle_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE BottomHorizontalEdgeBasis_Quadrangle_( &
+ order, L1, L2, ans, nrow, ncol, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order on bottom vertical edge (e3), 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) :: orient
+ !! orientaion of bottom and top edge
+ INTEGER(I4B), INTENT(IN) :: offset
+
+ INTEGER(I4B) :: k1, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(orient, kind=DFP)
+
+ nrow = SIZE(L1, 1) !! number of points of evaluation
+ ncol = order - 1 !! these are internal dof on edge
+
+ !! bottom edge
+ DO CONCURRENT(k1=2:order, ii=1:nrow)
+ ans(ii, offset + k1 - 1) = (mysign**k1) * L1(ii, k1) * L2(ii, 0)
+ END DO
+
+END SUBROUTINE BottomHorizontalEdgeBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! TopHorizontalEdgeBasis_Quadrangle_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE TopHorizontalEdgeBasis_Quadrangle_( &
+ order, L1, L2, ans, nrow, ncol, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order on bottom vertical edge (e3), 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) :: orient
+ !! orientaion of bottom and top edge
+ INTEGER(I4B), INTENT(IN) :: offset
+
+ INTEGER(I4B) :: k1, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(-orient, kind=DFP)
+ ! We multiply by -1 because the top edge is oriented leftwards
+ ! in master element
+
+ nrow = SIZE(L1, 1) !! number of points of evaluation
+ ncol = order - 1 !! these are internal dof on edge
+
+ !! top edge
+ DO CONCURRENT(k1=2:order, ii=1:nrow)
+ ans(ii, offset + k1 - 1) = (mysign**k1) * L1(ii, k1) * L2(ii, 1)
+ END DO
+END SUBROUTINE TopHorizontalEdgeBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! BottomHorizontalEdgeBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE BottomHorizontalEdgeBasisGradient_Quadrangle_( &
+ order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order on bottom vertical edge (e3), 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) :: orient
+ !! orientation of bottom and top horizontal edge
+ INTEGER(I4B), INTENT(IN) :: offset
+
+ !! internal variable
+ INTEGER(I4B) :: k1, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(orient, kind=DFP)
+
+ dim1 = SIZE(L1, 1) !! number of points of evaluation
+ dim2 = order - 1 !! these are internal dof on edge
+ dim3 = 2 !! x and y component of gradient
+
+ !! bottom edge
+ DO CONCURRENT(k1=2:order, ii=1:dim1)
+ ans(ii, offset + k1 - 1, 1) = (mysign**k1) * dL1(ii, k1) * L2(ii, 0)
+ ans(ii, offset + k1 - 1, 2) = (mysign**k1) * L1(ii, k1) * dL2(ii, 0)
+ END DO
+
+END SUBROUTINE BottomHorizontalEdgeBasisGradient_Quadrangle_
+
+!----------------------------------------------------------------------------
+! TopHorizontalEdgeBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE TopHorizontalEdgeBasisGradient_Quadrangle_( &
+ order, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, orient, offset)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! 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 = order - 1
+ !! dim3 = 2
+ INTEGER(I4B), INTENT(IN) :: orient
+ !! orientation of bottom and top horizontal edge
+ INTEGER(I4B), INTENT(IN) :: offset
+ !! data will we written in ans from offset + 1
+
+ !! internal variable
+ INTEGER(I4B) :: k1, ii
+ REAL(DFP) :: mysign
+
+ mysign = REAL(-orient, kind=DFP)
+ ! Here we multiply by -1 because the top edge is oriented leftwards &
+ ! in master element
+
+ dim1 = SIZE(L1, 1) !! number of points of evaluation
+ dim2 = order - 1 !! these are internal dof on edge
+ dim3 = 2
+
+ !! top edge
+ DO CONCURRENT(k1=2:order, ii=1:dim1)
+ ans(ii, offset + k1 - 1, 1) = (mysign**k1) * dL1(ii, k1) * L2(ii, 1)
+ ans(ii, offset + k1 - 1, 2) = (mysign**k1) * L1(ii, k1) * dL2(ii, 1)
+ END DO
+END SUBROUTINE TopHorizontalEdgeBasisGradient_Quadrangle_
+
+!----------------------------------------------------------------------------
+! 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), PARAMETER :: faceOrient(3) = [1, 1, 1]
+
+CALL LobattoEvalAll_(n=pb, x=x, ans=L1, nrow=nrow, ncol=ncol)
+CALL LobattoEvalAll_(n=qb, x=y, ans=L2, nrow=nrow, ncol=ncol)
+
+CALL CellBasis_Quadrangle2_(pb=pb, qb=qb, L1=L1, L2=L2, ans=ans, nrow=nrow, &
+ ncol=ncol, faceOrient=faceOrient, offset=0_I4B)
+
+END PROCEDURE CellBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CellBasis_Quadrangle2_(pb, qb, L1, L2, ans, nrow, ncol, &
+ faceOrient, offset)
+ 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
+ INTEGER(I4B), INTENT(IN) :: offset
+ !! data will we written in ans from offset + 1
+
+ !! 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)
+
+ p = pb
+ q = qb
+ IF (faceOrient(3) .LT. 0_I4B) THEN
+ p = qb
+ q = pb
+ END IF
+
+ DO CONCURRENT(k1=2:p, k2=2:q, ii=1:nrow)
+ ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1) = &
+ (o1**k1) * (o2**k2) * L1(ii, k1) * L2(ii, k2)
+ END DO
+
+END SUBROUTINE CellBasis_Quadrangle2_
+
+!----------------------------------------------------------------------------
+! CellBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE CellBasisGradient_Quadrangle2_( &
+ pb, qb, L1, L2, dL1, dL2, ans, dim1, dim2, dim3, faceOrient, offset)
+ 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)
+ !! face orientation
+ INTEGER(I4B), INTENT(IN) :: offset
+ !! data will we written in ans from offset + 1
+
+ !! 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)
+ p = pb
+ q = qb
+
+ IF (faceOrient(3) .LT. 0_I4B) THEN
+ p = qb
+ q = pb
+ END IF
+
+ DO CONCURRENT(k1=2:p, k2=2:q, ii=1:dim1)
+ ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 1) = &
+ (o1**k1) * (o2**k2) * dL1(ii, k1) * L2(ii, k2)
+
+ ans(ii, offset + (q - 1) * (k1 - 2) + k2 - 1, 2) = &
+ (o1**k1) * (o2**k2) * L1(ii, k1) * dL2(ii, k2)
+ END DO
+
+END SUBROUTINE CellBasisGradient_Quadrangle2_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Quadrangle1
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Quadrangle_( &
+ 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_Quadrangle_( &
+ 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_Quadrangle_( &
+ 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_Quadrangle_( &
+ 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_Quadrangle_( &
+ 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) :: indx(4), maxP, maxQ
+REAL(DFP), ALLOCATABLE :: L1(:, :), L2(:, :)
+LOGICAL(LGT) :: isok
+
+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)
+
+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))
+
+ncol = indx(2)
+
+! Bottom Horizontal Edge
+isok = (pe3 .GE. 2_I4B)
+IF (isok) THEN
+ CALL BottomHorizontalEdgeBasis_Quadrangle_( &
+ order=pe3, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), &
+ orient=pe3Orient, offset=ncol)
+ ncol = ncol + indx(2)
+END IF
+
+! Right Vertical Edge
+isok = (qe2 .GE. 2_I4B)
+IF (isok) THEN
+ CALL RightVerticalEdgeBasis_Quadrangle_( &
+ order=qe2, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), &
+ orient=qe2Orient, offset=ncol)
+ ncol = ncol + indx(2)
+END IF
+
+! Top Horizontal Edge
+isok = (pe4 .GE. 2_I4B)
+IF (isok) THEN
+ CALL TopHorizontalEdgeBasis_Quadrangle_( &
+ order=pe4, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), &
+ orient=pe4Orient, offset=ncol)
+ ncol = ncol + indx(2)
+END IF
+
+! Left Vertical Edge
+isok = (qe1 .GE. 2_I4B)
+IF (isok) THEN
+ CALL LeftVerticalEdgeBasis_Quadrangle_( &
+ order=qe1, L1=L1, L2=L2, ans=ans, nrow=indx(1), ncol=indx(2), &
+ orient=qe1Orient, offset=ncol)
+ ncol = ncol + indx(2)
+END IF
+
+! Cell basis function
+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, nrow=indx(1), ncol=indx(2), &
+ faceOrient=faceOrient, offset=ncol)
+ ncol = ncol + indx(2)
+END IF
+
+DEALLOCATE (L1, L2)
+END PROCEDURE HeirarchicalBasis_Quadrangle3_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Quadrangle1
+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)
+
+ALLOCATE (L1(1:dim1, 0:maxP), L2(1:dim1, 0:maxQ), &
+ dL1(1:dim1, 0:maxP), dL2(1:dim1, 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))
+
+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)
+
+! Bottom Horizontal Edge basis function
+isok = (pe3 .GE. 2_I4B)
+IF (isok) THEN
+ CALL BottomHorizontalEdgeBasisGradient_Quadrangle_( &
+ order=pe3, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), orient=pe3Orient, offset=dim2)
+ dim2 = dim2 + indx(2)
+END IF
+
+! Right Vertical Edge basis function
+isok = (qe2 .GE. 2_I4B)
+IF (isok) THEN
+ CALL RightVerticalEdgeBasisGradient_Quadrangle_( &
+ order=qe2, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), orient=qe2Orient, offset=dim2)
+ dim2 = dim2 + indx(2)
+END IF
+
+! Top Horizontal Edge basis function
+isok = (pe4 .GE. 2_I4B)
+IF (isok) THEN
+ CALL TopHorizontalEdgeBasisGradient_Quadrangle_( &
+ order=pe4, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), orient=pe4Orient, offset=dim2)
+ dim2 = dim2 + indx(2)
+END IF
+
+! Left Vertical Edge basis function
+isok = (qe1 .GE. 2_I4B)
+IF (isok) THEN
+ CALL LeftVerticalEdgeBasisGradient_Quadrangle_( &
+ order=qe1, L1=L1, L2=L2, dL1=dL1, dL2=dL2, ans=ans, dim1=indx(1), &
+ dim2=indx(2), dim3=indx(3), orient=qe1Orient, offset=dim2)
+ dim2 = dim2 + indx(2)
+END IF
+
+! Cell basis function
+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, &
+ dim1=indx(1), dim2=indx(2), dim3=indx(3), faceOrient=faceOrient, &
+ offset=dim2)
+
+ dim2 = dim2 + indx(2)
+END IF
+
+DEALLOCATE (L1, L2, dL1, dL2)
+END PROCEDURE HeirarchicalBasisGradient_Quadrangle3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE HierarchicalMethods
diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90
new file mode 100644
index 000000000..3b1eb41eb
--- /dev/null
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@InterpolationPointMethods.F90
@@ -0,0 +1,632 @@
+! 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(QuadrangleInterpolationUtility) InterpolationPointMethods
+USE LineInterpolationUtility, ONLY: InterpolationPoint_Line_
+USE ReallocateUtility, ONLY: Reallocate
+USE MappingUtility, ONLY: FromBiUnitQuadrangle2Quadrangle_
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Quadrangle1
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+nrow = 2_I4B
+isok = PRESENT(xij)
+IF (isok) nrow = SIZE(xij, 1)
+
+ncol = LagrangeDOF_Quadrangle(order=order)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL EquidistancePoint_Quadrangle1_(order=order, ans=ans, nrow=nrow, &
+ ncol=ncol, xij=xij)
+
+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
+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=TypeInterpolationOpt%equidistance, &
+ ipType2=TypeInterpolationOpt%equidistance, ans=ans, &
+ nrow=nrow, ncol=ncol, layout="VEFC", xij=xij)
+END PROCEDURE EquidistancePoint_Quadrangle2_
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Quadrangle1
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+isok = PRESENT(xij)
+
+IF (isok) 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
+END IF
+
+ALLOCATE (ans(nrow, ncol))
+ans(1:nrow, 1:ncol) = EquidistanceInPoint_Quadrangle2(p=order, q=order, &
+ xij=xij)
+END PROCEDURE EquidistanceInPoint_Quadrangle1
+
+!----------------------------------------------------------------------------
+! EquidistanceInPoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistanceInPoint_Quadrangle2
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+INTEGER(I4B) :: a, b, nrow, ncol
+LOGICAL(LGT) :: isok
+
+a = LagrangeDOF_Quadrangle(p=p, q=q)
+b = LagrangeInDOF_Quadrangle(p=p, q=q)
+
+isok = PRESENT(xij)
+IF (isok) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2
+END IF
+
+ALLOCATE (temp(nrow, a))
+
+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
+ ALLOCATE (ans(nrow, b))
+
+ ans(1:nrow, 1:b) = temp(1:nrow, a - b + 1:)
+END IF
+
+DEALLOCATE (temp)
+
+END PROCEDURE EquidistanceInPoint_Quadrangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE IJ2VEFC_Quadrangle
+CALL IJ2VEFC_Quadrangle_AntiClockwise(xi, eta, temp, p, q, 1_I4B)
+END PROCEDURE IJ2VEFC_Quadrangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE IJ2VEFC_Quadrangle_Clockwise
+! internal variables
+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(:, :)
+
+LOGICAL(LGT) :: isok, abool
+
+! vertices
+N = (p + 1) * (q + 1)
+cnt = 0
+ll = -1
+
+CALL GetEdgeConnectivityHelpClock(edgeConnectivity, pointsOrder, startNode)
+
+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
+
+! 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
+
+! 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
+ temp(1, ii) = xi(ii, 1)
+ temp(2, ii) = eta(ii, 1)
+ END DO
+ RETURN
+END IF
+
+ij(1, 1) = 1
+ij(2, 1) = 1
+
+ij(1, 2) = p + 1
+ij(2, 2) = 1
+
+ij(1, 3) = p + 1
+ij(2, 3) = q + 1
+
+ij(1, 4) = 1
+ij(2, 4) = q + 1
+
+isok = (p .GE. 1) .AND. (q .GE. 1)
+
+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))
+
+ END DO
+
+END IF
+
+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 (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
+
+ 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
+
+! internal nodes
+isok = (p .GE. 2) .AND. (q .GE. 2)
+IF (.NOT. isok) RETURN
+
+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))
+
+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)
+
+END PROCEDURE IJ2VEFC_Quadrangle_Clockwise
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise
+! internal variables
+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(:, :)
+LOGICAL(LGT) :: isok, abool
+
+! vertices
+N = (p + 1) * (q + 1)
+cnt = 0
+ll = -1
+
+CALL GetEdgeConnectivityHelpAntiClock(edgeConnectivity, pointsOrder, startNode)
+
+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: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]
+
+isok = (p .GE. 1) .AND. (q .GE. 1)
+IF (isok) THEN
+ DO ii = 1, 4
+ cnt = cnt + 1
+ jj = pointsOrder(ii)
+ temp(1:2, ii) = [&
+ & xi(ij(1, jj), ij(2, jj)), &
+ & eta(ij(1, jj), ij(2, jj)) &
+ & ]
+ END DO
+
+ 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
+ temp(1:2, cnt) = [&
+ & xi(ij(1, cnt), ij(2, cnt)), &
+ & eta(ij(1, cnt), ij(2, cnt))]
+ END DO
+ END DO
+END IF
+
+IF (ALL([p, q] .GE. 1_I4B)) THEN
+ 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 (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
+
+ 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
+
+ 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))
+
+ 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_AntiClockwise( &
+ 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
+ END IF
+
+END IF
+
+IF (ALLOCATED(xi_in)) DEALLOCATE (xi_in)
+IF (ALLOCATED(eta_in)) DEALLOCATE (eta_in)
+IF (ALLOCATED(temp_in)) DEALLOCATE (temp_in)
+
+END PROCEDURE IJ2VEFC_Quadrangle_AntiClockwise
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Quadrangle
+!----------------------------------------------------------------------------
+
+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)
+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
+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
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2
+END IF
+
+ncol = (p + 1) * (q + 1)
+
+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(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
+ 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_
+
+!----------------------------------------------------------------------------
+! GetEdgeConnectivityHelpAntiClock
+!----------------------------------------------------------------------------
+
+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
+
+!----------------------------------------------------------------------------
+! GetEdgeConnectivityHelpClock
+!----------------------------------------------------------------------------
+
+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
+
+END SUBMODULE InterpolationPointMethods
diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90
new file mode 100644
index 000000000..4b0cd5320
--- /dev/null
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@LagrangeMethods.F90
@@ -0,0 +1,587 @@
+! 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(QuadrangleInterpolationUtility) LagrangeMethods
+USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_
+USE GE_LUMethods, ONLY: GetLU, LUSolve
+USE InputUtility, ONLY: Input
+USE ErrorHandling, ONLY: Errormsg
+USE F95_BLAS, ONLY: GEMM
+USE StringUtility, ONLY: UpperCase
+USE GE_CompRoutineMethods, ONLY: GetInvMat
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "QuadrangleInterpolationUtility@LagrangeMethods"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! LagrangeDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDOF_Quadrangle1
+ans = (order + 1)**2
+END PROCEDURE LagrangeDOF_Quadrangle1
+
+!----------------------------------------------------------------------------
+! LagrangeDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDOF_Quadrangle2
+ans = (p + 1) * (q + 1)
+END PROCEDURE LagrangeDOF_Quadrangle2
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeInDOF_Quadrangle1
+ans = (order - 1)**2
+END PROCEDURE LagrangeInDOF_Quadrangle1
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeInDOF_Quadrangle2
+ans = (p - 1) * (q - 1)
+END PROCEDURE LagrangeInDOF_Quadrangle2
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Quadrangle1
+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
+
+!----------------------------------------------------------------------------
+! 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) :: 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
+
+!----------------------------------------------------------------------------
+! 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_
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Quadrangle2_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE MonomialBasis_Quadrangle_
+INTEGER(I4B) :: ii, jj, p1, ip
+
+nrow = SIZE(xij, 2)
+ncol = (p + 1) * (q + 1)
+
+p1 = p + 1
+
+DO CONCURRENT(ii=0:p, jj=0:q, ip=1:nrow)
+ ans(ip, p1 * jj + ii + 1) = xij(1, ip)**ii * xij(2, ip)**jj
+END DO
+
+END PROCEDURE MonomialBasis_Quadrangle_
+
+!----------------------------------------------------------------------------
+! 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, 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=TypeElemNameOpt%Quadrangle, 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_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
+
+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_Quadrangle2_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Quadrangle3
+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) :: 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Quadrangle4_
+INTEGER(I4B) :: basisType0
+
+basisType0 = Input(default=TypePolynomialOpt%monomial, option=basisType)
+
+IF (basisType0 .EQ. TypePolynomialOpt%hierarchical) THEN
+ 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
+
+! 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) :: 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Quadrangle5_
+INTEGER(I4B) :: basisType(2)
+LOGICAL(LGT) :: isok
+
+basisType(1) = Input(default=TypePolynomialOpt%monomial, option=basisType1)
+basisType(2) = Input(default=TypePolynomialOpt%monomial, option=basisType2)
+
+isok = ALL(basisType .EQ. TypePolynomialOpt%hierarchical)
+IF (isok) THEN
+ ! 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 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_
+
+!----------------------------------------------------------------------------
+! 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, isCoeff
+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=TypePolynomialOpt%monomial, option=basisType)
+firstCall0 = INPUT(default=.TRUE., option=firstCall)
+
+isCoeff = PRESENT(coeff)
+IF (isCoeff) THEN
+
+ IF (firstCall0) THEN
+ 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
+
+ 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 (TypePolynomialOpt%monomial)
+
+ CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
+#ifdef DEBUG_VER
+
+ 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
+
+#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 (TypePolynomialOpt%hierarchical)
+
+ ! 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
+
+ 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
+
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = DOT_PRODUCT(coeff0(:, ii), xx(1, :))
+END DO
+
+END PROCEDURE LagrangeEvalAll_Quadrangle1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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) :: isok, firstCall0
+REAL(DFP) :: coeff0(SIZE(xij, 2), SIZE(xij, 2)), xx(SIZE(x, 2), SIZE(xij, 2))
+
+firstCall0 = Input(default=.TRUE., option=firstCall)
+isok = PRESENT(coeff)
+
+IF (isok) THEN
+
+ CALL LagrangeEvalAll_Quadrangle_( &
+ order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff, &
+ xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+ELSE
+
+ CALL LagrangeEvalAll_Quadrangle_( &
+ order=order, x=x, xij=xij, ans=ans, nrow=nrow, ncol=ncol, coeff=coeff0, &
+ xx=xx, firstCall=firstCall0, basisType=basisType, alpha=alpha, &
+ beta=beta, lambda=lambda)
+
+END IF
+END PROCEDURE LagrangeEvalAll_Quadrangle2_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Quadrangle_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Quadrangle3_
+INTEGER(I4B) :: basisType0, indx(2)
+
+! coeff0(SIZE(xij, 2), SIZE(xij, 2))
+! xx(SIZE(x, 2), SIZE(xij, 2))
+! degree(SIZE(xij, 2), 2)
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
+
+basisType0 = INPUT(default=TypePolynomialOpt%Monomial, option=basisType)
+
+! coeff = LagrangeCoeff_Quadrangle(&
+IF (firstCall) &
+ CALL LagrangeCoeff_Quadrangle_( &
+ order=order, xij=xij, basisType=basisType0, alpha=alpha, beta=beta, &
+ lambda=lambda, ans=coeff, nrow=indx(1), ncol=indx(2))
+
+SELECT CASE (basisType0)
+
+CASE (TypePolynomialOpt%Monomial)
+ CALL MonomialBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, &
+ nrow=indx(1), ncol=indx(2))
+
+CASE (TypePolynomialOpt%Hierarchical)
+ CALL HeirarchicalBasis_Quadrangle_(p=order, q=order, xij=x, ans=xx, &
+ nrow=indx(1), ncol=indx(2))
+
+CASE DEFAULT
+ 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
+
+! indx(1) should be equal to nrow
+! indx(2) should be equal to ncol
+! ans = MATMUL(xx, coeff0)
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx(1:nrow, 1:ncol), &
+ B=coeff(1:ncol, 1:ncol))
+
+END PROCEDURE LagrangeEvalAll_Quadrangle3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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, isCoeff
+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, areal, breal
+
+dim1 = SIZE(x, 2)
+dim2 = SIZE(xij, 2)
+dim3 = 2
+
+basisType0 = INPUT(default=TypePolynomialOpt%monomial, option=basisType)
+firstCall0 = INPUT(default=.TRUE., option=firstCall)
+
+isCoeff = PRESENT(coeff)
+
+IF (isCoeff) THEN
+
+ IF (firstCall0) THEN
+ ! 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(&
+ 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 (TypePolynomialOpt%monomial)
+ ! degree = LagrangeDegree_Quadrangle(order=order)
+ CALL LagrangeDegree_Quadrangle_(order=order, ans=degree, nrow=indx(1), &
+ ncol=indx(2))
+
+#ifdef DEBUG_VER
+ 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
+#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)
+
+ 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 (TypePolynomialOpt%hierarchical)
+
+ ! 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( &
+ 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(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0)
+END DO
+
+END PROCEDURE LagrangeGradientEvalAll_Quadrangle1_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE LagrangeMethods
diff --git a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90
similarity index 59%
rename from src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90
rename to src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90
index b0fac6f68..11cc697b5 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@SqrtMethods.F90
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@Methods.F90
@@ -13,39 +13,32 @@
!
! You should have received a copy of the GNU General Public License
! along with this program. If not, see
-!
-
-#define _ELEM_METHOD_ SQRT
-SUBMODULE(FEVariable_Method) SqrtMethods
-USE BaseMethod
+SUBMODULE(QuadrangleInterpolationUtility) Methods
IMPLICIT NONE
CONTAINS
!----------------------------------------------------------------------------
-! SQRT
+! RefElemDomain_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE fevar_sqrt
-SELECT CASE (obj%rank)
-!!
-CASE (SCALAR)
-#include "./ScalarElemMethod.inc"
-!!
-CASE (VECTOR)
-#include "./VectorElemMethod.inc"
-!!
-CASE (MATRIX)
-#include "./MatrixElemMethod.inc"
-!!
-END SELECT
-!!
-END PROCEDURE fevar_sqrt
+MODULE PROCEDURE RefElemDomain_Quadrangle
+ans = "BIUNIT"
+END PROCEDURE RefElemDomain_Quadrangle
!----------------------------------------------------------------------------
-!
+! FacetConnectivity
!----------------------------------------------------------------------------
-END SUBMODULE SqrtMethods
+MODULE PROCEDURE FacetConnectivity_Quadrangle
+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
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Quadrangle3
+!----------------------------------------------------------------------------
-#undef _ELEM_METHOD_
+END SUBMODULE Methods
diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90
new file mode 100644
index 000000000..565f4ee37
--- /dev/null
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@QuadratureMethods.F90
@@ -0,0 +1,206 @@
+! 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(QuadrangleInterpolationUtility) QuadratureMethods
+USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, &
+ QuadraturePoint_Line_
+USE MappingUtility, ONLY: FromBiUnitQuadrangle2Quadrangle_, &
+ FromBiUnitQuadrangle2UnitQuadrangle_, &
+ JacobianQuadrangle
+USE StringUtility, ONLY: UpperCase
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! QuadratureNumber_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadratureNumber_Quadrangle
+ans(1) = QuadratureNumber_Line(order=p, quadType=quadType1)
+ans(2) = QuadratureNumber_Line(order=q, quadType=quadType2)
+END PROCEDURE QuadratureNumber_Quadrangle
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Quadrangle1
+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
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Quadrangle2
+INTEGER(I4B) :: nipsx(1), nipsy(1), nrow, ncol
+
+nipsx(1) = QuadratureNumber_Line(order=p, quadType=quadType1)
+nipsy(1) = QuadratureNumber_Line(order=q, quadType=quadType2)
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), 2)
+ELSE
+ nrow = 2
+END IF
+
+nrow = nrow + 1
+ncol = nipsx(1) * nipsy(1)
+
+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_Quadrangle2
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Quadrangle3
+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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Quadrangle4
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = MAX(SIZE(xij, 1), 2)
+ELSE
+ nrow = 2
+END IF
+
+nrow = nrow + 1
+ncol = nipsx(1) * nipsy(1)
+
+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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Quadrangle1_
+! internal variables
+REAL(DFP) :: x(4, nipsx(1)), y(2, nipsy(1)), areal
+INTEGER(I4B) :: ii, jj, nsd, np, nq
+CHARACTER(len=1) :: astr
+
+REAL(DFP), PARAMETER :: x12(1, 2) = RESHAPE([-1.0_DFP, 1.0_DFP], [1, 2])
+
+IF (PRESENT(xij)) THEN
+ nsd = MAX(SIZE(xij, 1), 2)
+ELSE
+ nsd = 2
+END IF
+
+nrow = nsd + 1
+ncol = nipsx(1) * nipsy(1)
+
+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
+ 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
+
+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_
+
+END SUBMODULE QuadratureMethods
diff --git a/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90 b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90
new file mode 100644
index 000000000..8ee7e7fc8
--- /dev/null
+++ b/src/submodules/Quadrangle/src/QuadrangleInterpolationUtility@TensorProdMethods.F90
@@ -0,0 +1,163 @@
+! 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(QuadrangleInterpolationUtility) TensorProdMethods
+USE LineInterpolationUtility, ONLY: BasisEvalAll_Line_, &
+ BasisGradientEvalAll_Line_
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! TensorProdOrthoPol_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasis_Quadrangle1
+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) :: k1, k2, ii
+
+nrow = SIZE(xij, 2)
+ncol = (p + 1) * (q + 1)
+
+CALL BasisEvalAll_Line_( &
+ order=p, x=xij(1, :), refLine="BIUNIT", basisType=basisType1, &
+ alpha=alpha1, beta=beta1, lambda=lambda1, ans=P1, nrow=k1, ncol=k2)
+
+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 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_
+
+!----------------------------------------------------------------------------
+! TensorProdOrthoPol_Quadrangle
+!----------------------------------------------------------------------------
+
+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
+
+!----------------------------------------------------------------------------
+! TensorProdOrthoPol_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasis_Quadrangle2_
+REAL(DFP) :: xij(2, SIZE(x) * SIZE(y))
+INTEGER(I4B) :: ii, jj
+
+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
+
+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_
+
+!----------------------------------------------------------------------------
+! TensorProdBasisGradient_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE TensorProdBasisGradient_Quadrangle1
+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) :: k1, k2, cnt, indx(3)
+
+dim1 = SIZE(xij, 2)
+dim2 = (p + 1) * (q + 1)
+dim3 = 2
+
+! 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(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 SUBMODULE TensorProdMethods
diff --git a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90 b/src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90
similarity index 81%
rename from src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90
rename to src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90
index 76b697b41..a530d0826 100644
--- a/src/submodules/Geometry/src/ReferenceQuadrangle_Method@Methods.F90
+++ b/src/submodules/Quadrangle/src/ReferenceQuadrangle_Method@Methods.F90
@@ -20,25 +20,42 @@
! summary: This submodule contains method for [[ReferenceQuadrangle_]]
SUBMODULE(ReferenceQuadrangle_Method) Methods
-USE ReferenceElement_Method
+USE GlobalData, ONLY: 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 AppendUtility
-USE StringUtility
-USE ArangeUtility
-USE InputUtility
-USE SortUtility
-USE ReallocateUtility
-USE Display_Method
+USE ApproxUtility, ONLY: OPERATOR(.approxeq.)
+
+USE AppendUtility, ONLY: OPERATOR(.append.)
+
+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
+USE BaseType, ONLY: TypeElemNameOpt, TypeInterpolationOpt
+
IMPLICIT NONE
CONTAINS
@@ -48,15 +65,15 @@
MODULE PROCEDURE ElementName_Quadrangle
SELECT CASE (elemType)
-CASE (Quadrangle4)
+CASE (TypeElemNameOpt%Quadrangle)
ans = "Quadrangle4"
-CASE (Quadrangle8)
+CASE (TypeElemNameOpt%Quadrangle8)
ans = "Quadrangle8"
-CASE (Quadrangle9)
+CASE (TypeElemNameOpt%Quadrangle9)
ans = "Quadrangle9"
-CASE (Quadrangle16)
+CASE (TypeElemNameOpt%Quadrangle16)
ans = "Quadrangle16"
-CASE default
+CASE DEFAULT
ans = ""
END SELECT
END PROCEDURE ElementName_Quadrangle
@@ -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,14 +116,14 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE TotalNodesInElement_Quadrangle
-SELECT CASE (ElemType)
-CASE (Quadrangle4)
+SELECT CASE (elemType)
+CASE (TypeElemNameOpt%Quadrangle)
ans = 4
-CASE (Quadrangle8)
+CASE (TypeElemNameOpt%Quadrangle8)
ans = 8
-CASE (Quadrangle9)
+CASE (TypeElemNameOpt%Quadrangle9)
ans = 9
-CASE (Quadrangle16)
+CASE (TypeElemNameOpt%Quadrangle16)
ans = 16
CASE DEFAULT
ans = 0
@@ -118,14 +135,14 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE ElementOrder_Quadrangle
-SELECT CASE (ElemType)
-CASE (Quadrangle4)
+SELECT CASE (elemType)
+CASE (TypeElemNameOpt%Quadrangle)
ans = 1
-CASE (Quadrangle8)
+CASE (TypeElemNameOpt%Quadrangle8)
ans = 2
-CASE (Quadrangle9)
+CASE (TypeElemNameOpt%Quadrangle9)
ans = 2
-CASE (Quadrangle16)
+CASE (TypeElemNameOpt%Quadrangle16)
ans = 3
END SELECT
END PROCEDURE ElementOrder_Quadrangle
@@ -137,13 +154,13 @@
MODULE PROCEDURE ElementType_Quadrangle
SELECT CASE (elemName)
CASE ("Quadrangle4", "Quadrangle")
- ans = Quadrangle4
+ ans = TypeElemNameOpt%Quadrangle
CASE ("Quadrangle8")
- ans = Quadrangle8
+ ans = TypeElemNameOpt%Quadrangle8
CASE ("Quadrangle9")
- ans = Quadrangle9
+ ans = TypeElemNameOpt%Quadrangle9
CASE ("Quadrangle16")
- ans = Quadrangle16
+ ans = TypeElemNameOpt%Quadrangle16
CASE DEFAULT
ans = 0
END SELECT
@@ -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
@@ -184,7 +201,7 @@
DO jj = 1, tsize
ans(ii)%topology(jj) = Referencetopology( &
- & nptrs=topo%nptrs(jj:jj), name=Point)
+ nptrs=topo%nptrs(jj:jj), name=TypeElemNameOpt%Point)
END DO
ans(ii)%topology(tsize + 1) = Referencetopology( &
@@ -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]
@@ -215,23 +232,22 @@
ans(ii)%xiDimension = 1
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)%interpolationPointType = TypeInterpolationOpt%Equidistance
+ ans(ii)%xij = InterpolationPoint_Line( &
+ order=order, ipType=TypeInterpolationOpt%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=TypeElemNameOpt%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
@@ -246,13 +262,13 @@
MODULE PROCEDURE Quadranglename1
SELECT CASE (order)
CASE (1)
- ans = Quadrangle4
+ ans = TypeElemNameOpt%Quadrangle
CASE (2)
- ans = Quadrangle9
+ ans = TypeElemNameOpt%Quadrangle9
CASE (3)
- ans = Quadrangle16
+ ans = TypeElemNameOpt%Quadrangle16
CASE (4:)
- ans = Quadrangle16 + order - 3_I4B
+ ans = TypeElemNameOpt%Quadrangle16 + order - 3_I4B
END SELECT
END PROCEDURE Quadranglename1
@@ -293,19 +309,19 @@
obj%entityCounts = [4, 4, 1, 0]
obj%xidimension = 2
-obj%name = Quadrangle4
+obj%name = TypeElemNameOpt%Quadrangle
obj%order = 1
obj%NSD = NSD
ALLOCATE (obj%topology(9))
-obj%topology(1) = ReferenceTopology([1], Point)
-obj%topology(2) = ReferenceTopology([2], Point)
-obj%topology(3) = ReferenceTopology([3], Point)
-obj%topology(4) = ReferenceTopology([4], Point)
-obj%topology(5) = ReferenceTopology([1, 2], Line2)
-obj%topology(6) = ReferenceTopology([2, 3], Line2)
-obj%topology(7) = ReferenceTopology([3, 4], Line2)
-obj%topology(8) = ReferenceTopology([4, 1], Line2)
-obj%topology(9) = ReferenceTopology([1, 2, 3, 4], Quadrangle4)
+obj%topology(1) = ReferenceTopology([1], TypeElemNameOpt%Point)
+obj%topology(2) = ReferenceTopology([2], TypeElemNameOpt%Point)
+obj%topology(3) = ReferenceTopology([3], TypeElemNameOpt%Point)
+obj%topology(4) = ReferenceTopology([4], TypeElemNameOpt%Point)
+obj%topology(5) = ReferenceTopology([1, 2], TypeElemNameOpt%Line)
+obj%topology(6) = ReferenceTopology([2, 3], TypeElemNameOpt%Line)
+obj%topology(7) = ReferenceTopology([3, 4], TypeElemNameOpt%Line)
+obj%topology(8) = ReferenceTopology([4, 1], TypeElemNameOpt%Line)
+obj%topology(9) = ReferenceTopology([1, 2, 3, 4], TypeElemNameOpt%Quadrangle)
obj%highorderElement => highorderElement_Quadrangle
END PROCEDURE Initiate_ref_Quadrangle
@@ -337,13 +353,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]
@@ -353,7 +366,7 @@
obj%NSD = refelem%NSD
ALLOCATE (obj%topology(SUM(obj%entityCounts)))
DO I = 1, NNS
- obj%topology(I) = ReferenceTopology([I], Point)
+ obj%topology(I) = ReferenceTopology([I], TypeElemNameOpt%Point)
END DO
aintvec = [1, 2] .append.arange(5_I4B, 3_I4B + order)
obj%topology(NNS + 1) = ReferenceTopology(aintvec, Linename(order=order))
@@ -543,17 +556,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
!----------------------------------------------------------------------------
@@ -650,11 +664,24 @@ END SUBROUTINE PARALLELOGRAMAREA2D
! GetFaceElemType_Quadrangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Quadrangle
-INTEGER(I4B) :: order
-order = ElementOrder_Quadrangle(Input(default=Quadrangle, option=elemType))
-IF (PRESENT(faceElemType)) faceElemType(1:4) = ElementName_Line(order)
+MODULE PROCEDURE GetFaceElemType_Quadrangle1
+INTEGER(I4B) :: order, elemType0
+
+elemType0 = Input(default=TypeElemNameOpt%Quadrangle, option=elemType)
+order = ElementOrder_Quadrangle(elemType0)
+IF (PRESENT(faceElemType)) faceElemType(1:4) = LineName(order)
IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = order + 1
-END PROCEDURE GetFaceElemType_Quadrangle
+END PROCEDURE GetFaceElemType_Quadrangle1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Quadrangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Quadrangle2
+INTEGER(I4B) :: order
+order = ElementOrder_Quadrangle(elemType)
+faceElemType = LineName(order)
+tFaceNodes = order + 1
+END PROCEDURE GetFaceElemType_Quadrangle2
END SUBMODULE Methods
diff --git a/src/submodules/QuadraturePoint/CMakeLists.txt b/src/submodules/QuadraturePoint/CMakeLists.txt
index 69ce7a34f..218d4895d 100644
--- a/src/submodules/QuadraturePoint/CMakeLists.txt
+++ b/src/submodules/QuadraturePoint/CMakeLists.txt
@@ -1,25 +1,25 @@
-# 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
+ ${src_path}/QuadraturePoint_Method@FacetQuadratureMethods.F90
+ ${src_path}/QuadraturePoint_Method@SetMethods.F90)
diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90
index 9387b1aab..93cb47ddd 100755
--- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@ConstructorMethods.F90
@@ -15,13 +15,40 @@
! along with this program. If not, see
!
-!> author: Vikas Sharma, Ph. D.
-! date: 3 March 2021
! summary: Constructor methods for [[QuadraturePoint_]]
SUBMODULE(QuadraturePoint_Method) ConstructorMethods
-USE BaseMethod
+USE GlobalData, ONLY: stderr
+
+USE ErrorHandling, ONLY: ErrorMsg
+
+USE BaseInterpolation_Method, ONLY: InterpolationPoint_ToChar, &
+ InterpolationPoint_ToInteger, &
+ InterpolationPoint_ToString
+
+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
!----------------------------------------------------------------------------
@@ -29,936 +56,483 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePointIDToName
-ans = BaseInterpolation_ToString(name)
+ans = InterpolationPoint_ToString(name)
END PROCEDURE QuadraturePointIDToName
+!----------------------------------------------------------------------------
+! QuadraturePointIDToName
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_ToChar
+ans = InterpolationPoint_ToChar(name)
+END PROCEDURE QuadraturePoint_ToChar
+
!----------------------------------------------------------------------------
! QuadraturePointNameToID
!----------------------------------------------------------------------------
MODULE PROCEDURE QuadraturePointNameToID
-ans = BaseInterpolation_ToInteger(name)
+ans = InterpolationPoint_ToInteger(name)
END PROCEDURE QuadraturePointNameToID
!----------------------------------------------------------------------------
-! Initiate
+! QuadraturePoint
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE quad_Constructor1
+obj%points = points
+obj%tXi = SIZE(points, 1) - 1
+END PROCEDURE quad_Constructor1
+
+!----------------------------------------------------------------------------
+! QuadraturePoint_Pointer
!----------------------------------------------------------------------------
-MODULE PROCEDURE quad_initiate1
+MODULE PROCEDURE quad_Constructor_1
+ALLOCATE (obj)
obj%points = points
obj%tXi = SIZE(points, 1) - 1
-! No of row minus one
-END PROCEDURE quad_initiate1
+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
+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)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, &
+ routine="obj_QuadratureNumber1()", &
+ line=__LINE__, &
+ unitno=stderr)
+ STOP
+#endif
+
+END SELECT
+
+END PROCEDURE obj_QuadratureNumber1
+
+!----------------------------------------------------------------------------
+! Copy
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Copy
+INTEGER(I4B) :: s(2)
+LOGICAL(LGT) :: isok
+
+obj%txi = obj2%txi
+isok = ALLOCATED(obj2%points)
+
+IF (isok) THEN
+ s = SHAPE(obj2%points)
+ CALL Reallocate(obj%points, s(1), s(2))
+ obj%points(1:s(1), 1:s(2)) = obj2%points(1:s(1), 1:s(2))
+END IF
+END PROCEDURE obj_Copy
+
+!----------------------------------------------------------------------------
+! 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
-
-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
+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_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
-END PROCEDURE quad_initiate8
+!----------------------------------------------------------------------------
+! Initiate
+!----------------------------------------------------------------------------
+
+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)
+LOGICAL(LGT) :: isok
+
+topo = ElementTopology(elemType)
+
+ii = XiDimension(elemType)
+
+isok = PRESENT(xij)
+IF (isok) 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)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, routine="obj_Initiate11()", &
+ line=__LINE__, unitno=stderr)
+ STOP
+#endif
+
+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
+LOGICAL(LGT) :: isok
+
+topo = ElementTopology(elemType)
+
+ii = XiDimension(elemType)
+
+isok = PRESENT(xij)
+IF (isok) 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)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, &
+ routine="obj_Initiate12()", &
+ line=__LINE__, &
+ unitno=stderr)
+ STOP
+#endif
+
+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@FacetQuadratureMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90
new file mode 100644
index 000000000..4f2cbc017
--- /dev/null
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@FacetQuadratureMethods.F90
@@ -0,0 +1,202 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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(QuadraturePoint_Method) FacetQuadratureMethods
+USE GlobalData, ONLY: stderr
+USE ErrorHandling, ONLY: ErrorMsg
+USE BaseInterpolation_Method, ONLY: InterpolationPoint_ToChar, &
+ InterpolationPoint_ToInteger, &
+ InterpolationPoint_ToString
+
+USE ReallocateUtility, ONLY: Reallocate
+
+USE ReferenceElement_Method, ONLY: ElementTopology, &
+ XiDimension, ReferenceElementInfo
+
+USE LineInterpolationUtility, ONLY: QuadratureNumber_Line, &
+ QuadraturePoint_Line_
+USE TriangleInterpolationUtility, ONLY: QuadraturePoint_Triangle_, &
+ QuadratureNumber_Triangle, &
+ FacetConnectivity_Triangle
+
+USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_, &
+ QuadratureNumber_Quadrangle, &
+ FacetConnectivity_Quadrangle
+
+USE TetrahedronInterpolationUtility, ONLY: QuadraturePoint_Tetrahedron_, &
+ QuadratureNumber_Tetrahedron
+
+USE HexahedronInterpolationUtility, ONLY: QuadraturePoint_Hexahedron_, &
+ QuadratureNumber_Hexahedron
+
+USE BaseType, ONLY: elem => TypeElemNameOpt
+
+USE MappingUtility, ONLY: FromBiUnitLine2Segment_
+
+IMPLICIT NONE
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_InitiateFacetQuadrature1
+CALL InitiateFacetQuadrature(obj=obj, facetQuad=facetQuad, &
+ localFaceNumber=localFaceNumber, &
+ 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_InitiateFacetQuadrature1
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_InitiateFacetQuadrature2
+CALL InitiateFacetQuadrature(obj=obj, facetQuad=facetQuad, &
+ localFaceNumber=localFaceNumber, &
+ 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_InitiateFacetQuadrature2
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_InitiateFacetQuadrature3
+INTEGER(I4B) :: topo, nrow, ncol, nipsx(1), nsd
+INTEGER(I4B) :: facecon(ReferenceElementInfo%maxPoints, &
+ ReferenceElementInfo%maxEdges)
+REAL(DFP) :: x1(3), x2(3)
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+
+CASE (elem%triangle)
+
+ nsd = SIZE(xij, 1)
+ nrow = nsd + 1
+ nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1)
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+ CALL Reallocate(facetQuad%points, 2, ncol)
+
+ ! Get quadrature points on [-1, 1]
+ CALL QuadraturePoint_Line_(nips=nipsx, &
+ quadType=quadratureType1, &
+ layout="INCREASING", &
+ alpha=alpha1, &
+ beta=beta1, &
+ lambda=lambda1, &
+ ans=facetQuad%points, &
+ nrow=nrow, ncol=ncol)
+
+ facecon(1:2, 1:3) = FacetConnectivity_Triangle()
+ x1(1:nsd) = xij(1:nsd, facecon(1, localFaceNumber))
+ x2(1:nsd) = xij(1:nsd, facecon(2, localFaceNumber))
+
+ ! Map quadrature points from[-1, 1] to the face of quadrangle
+ CALL FromBiUnitLine2Segment_(xin=facetQuad%points(1, :), &
+ x1=x1(1:nsd), &
+ x2=x2(1:nsd), &
+ ans=obj%points, &
+ nrow=nrow, ncol=ncol)
+
+ obj%txi = SIZE(obj%points, 1) - 1
+ facetQuad%txi = SIZE(facetQuad%points, 1) - 1
+
+ CALL GetQuadratureWeights_(obj=facetQuad, &
+ weights=obj%points(obj%txi + 1, :), &
+ tsize=ncol)
+
+CASE (elem%quadrangle)
+
+ nsd = SIZE(xij, 1)
+ nrow = nsd + 1
+ nipsx(1) = QuadratureNumber_Line(order=p, quadtype=quadratureType1)
+ ncol = nipsx(1)
+
+ CALL Reallocate(obj%points, nrow, ncol)
+ CALL Reallocate(facetQuad%points, 2, ncol)
+
+ ! Get quadrature points on [-1, 1]
+ CALL QuadraturePoint_Line_(nips=nipsx, &
+ quadType=quadratureType1, &
+ layout="INCREASING", &
+ alpha=alpha1, &
+ beta=beta1, &
+ lambda=lambda1, &
+ ans=facetQuad%points, &
+ nrow=nrow, ncol=ncol)
+
+ facecon(1:2, 1:4) = FacetConnectivity_Quadrangle()
+ x1(1:nsd) = xij(1:nsd, facecon(1, localFaceNumber))
+ x2(1:nsd) = xij(1:nsd, facecon(2, localFaceNumber))
+
+ ! Map quadrature points from[-1, 1] to the face of quadrangle
+ CALL FromBiUnitLine2Segment_(xin=facetQuad%points(1, :), &
+ x1=x1(1:nsd), &
+ x2=x2(1:nsd), &
+ ans=obj%points, &
+ nrow=nrow, ncol=ncol)
+
+ obj%txi = SIZE(obj%points, 1) - 1
+ facetQuad%txi = SIZE(facetQuad%points, 1) - 1
+
+ CALL GetQuadratureWeights_(obj=facetQuad, &
+ weights=obj%points(obj%txi + 1, :), &
+ tsize=ncol)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL Errormsg(msg="No case found for give topo", &
+ file=__FILE__, routine="obj_Initiate11()", &
+ line=__LINE__, unitno=stderr)
+ STOP
+#endif
+
+END SELECT
+
+END PROCEDURE obj_InitiateFacetQuadrature3
+
+!----------------------------------------------------------------------------
+! InitiateFacetQuadrature
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_InitiateFacetQuadrature4
+
+END PROCEDURE obj_InitiateFacetQuadrature4
+
+END SUBMODULE FacetQuadratureMethods
diff --git a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90
index 126af77a7..67ae240d0 100755
--- a/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@GetMethods.F90
@@ -20,7 +20,16 @@
! summary: Constructor methods for [[Quadraturepoints_]]
SUBMODULE(QuadraturePoint_Method) GetMethods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
+USE BaseType, ONLY: TypeElemNameOpt
+
+USE LineInterpolationUtility, ONLY: QuadratureNumber_Line
+USE TriangleInterpolationUtility, ONLY: QuadratureNumber_Triangle
+USE QuadrangleInterpolationUtility, ONLY: QuadratureNumber_Quadrangle
+USE TetrahedronInterpolationUtility, ONLY: QuadratureNumber_Tetrahedron
+USE HexahedronInterpolationUtility, ONLY: QuadratureNumber_Hexahedron
+USE ReferenceElement_Method, ONLY: ElementTopology
+
IMPLICIT NONE
CONTAINS
@@ -28,46 +37,106 @@
! 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_GetTotalQuadraturepoints1
ans = SIZE(obj, 2)
-END PROCEDURE quad_getTotalQuadraturepoints
+END PROCEDURE obj_GetTotalQuadraturepoints1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetTotalQuadraturePoints2
+INTEGER(I4B) :: topo, myint(3)
+
+topo = ElementTopology(elemType)
+
+SELECT CASE (topo)
+CASE (TypeElemNameOpt%line)
+ ans = QuadratureNumber_Line(order=p, quadtype=quadratureType1)
+
+CASE (TypeElemNameOpt%triangle)
+ ans = QuadratureNumber_Triangle(order=p, quadtype=quadratureType1)
+
+CASE (TypeElemNameOpt%quadrangle)
+ myint(1:2) = QuadratureNumber_Quadrangle(p=p, q=q, &
+ quadType1=quadratureType1, &
+ quadType2=quadratureType2)
+ ans = myint(1) * myint(2)
+
+CASE (TypeElemNameOpt%tetrahedron)
+ ans = QuadratureNumber_Tetrahedron(order=p, quadtype=quadratureType1)
+
+CASE (TypeElemNameOpt%hexahedron)
+ myint(1:3) = QuadratureNumber_Hexahedron(p=p, q=q, r=r, &
+ quadType1=quadratureType1, &
+ quadType2=quadratureType2, &
+ quadType3=quadratureType3)
+ ans = PRODUCT(myint)
+
+! CASE (Prism)
+! CASE (Pyramid)
+
+END SELECT
+
+END PROCEDURE obj_GetTotalQuadraturePoints2
!----------------------------------------------------------------------------
! 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 +144,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/FEVariable/src/FEVariable_Method@PowerMethods.F90 b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90
similarity index 63%
rename from src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90
rename to src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90
index e8eff5ef2..d4f75dae1 100644
--- a/src/submodules/FEVariable/src/FEVariable_Method@PowerMethods.F90
+++ b/src/submodules/QuadraturePoint/src/QuadraturePoint_Method@SetMethods.F90
@@ -1,5 +1,6 @@
! This program is a part of EASIFEM library
-! Copyright (C) 2020-2021 Vikas Sharma, Ph.D
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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
@@ -15,33 +16,26 @@
! along with this program. If not, see
!
-SUBMODULE(FEVariable_Method) PowerMethods
-USE BaseMethod
+SUBMODULE(QuadraturePoint_Method) SetMethods
+USE ReallocateUtility, ONLY: Reallocate
IMPLICIT NONE
+
CONTAINS
!----------------------------------------------------------------------------
-! Power
+! Set
!----------------------------------------------------------------------------
-MODULE PROCEDURE fevar_power
-SELECT CASE (obj%rank)
-!!
-CASE (SCALAR)
-#include "./ScalarPower.inc"
-!!
-CASE (VECTOR)
-#include "./VectorPower.inc"
-!!
-CASE (MATRIX)
-#include "./MatrixPower.inc"
-!!
-END SELECT
-!!
-END PROCEDURE fevar_power
+MODULE PROCEDURE obj_Set1
+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_Set1
-END SUBMODULE PowerMethods
+END SUBMODULE SetMethods
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/RealVector/src/RealVector_AddMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90
index 8828109e9..21482901d 100644
--- a/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90
+++ b/src/submodules/RealVector/src/RealVector_AddMethods@Methods.F90
@@ -16,7 +16,16 @@
!
SUBMODULE(RealVector_AddMethods) Methods
-USE DOF_Method, ONLY: DOF_Add => Add
+USE GlobalData, ONLY: DOF_FMT, NODES_FMT
+
+USE DOF_Method, ONLY: DOF_Add => Add, &
+ OPERATOR(.tdof.), &
+ GetNodeLoc
+
+USE F77_BLAS, ONLY: F77_AXPY
+
+USE F95_BLAS, ONLY: F95_AXPY => AXPY
+
IMPLICIT NONE
CONTAINS
@@ -24,232 +33,338 @@
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add1
-obj%val = obj%val + scale * VALUE
-END PROCEDURE obj_add1
+MODULE PROCEDURE obj_Add1
+! obj%val = obj%val + scale * VALUE
+REAL(DFP) :: aval(1)
+INTEGER(I4B) :: N
+aval(1) = VALUE
+N = SIZE(obj%val)
+CALL F77_AXPY(N=N, A=scale, X=aval, INCX=0_I4B, Y=obj%val, INCY=1_I4B)
+END PROCEDURE obj_Add1
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add2
-obj%val = obj%val + scale * VALUE
-END PROCEDURE obj_add2
+MODULE PROCEDURE obj_Add2
+! obj%val = obj%val + scale * VALUE
+CALL F95_AXPY(A=scale, X=VALUE, Y=obj%val)
+END PROCEDURE obj_Add2
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add3
+MODULE PROCEDURE obj_Add3
obj%val(nodenum) = obj%val(nodenum) + scale * VALUE
-END PROCEDURE obj_add3
+END PROCEDURE obj_Add3
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add4
+MODULE PROCEDURE obj_Add4
obj%val(nodenum) = obj%val(nodenum) + scale * VALUE
-END PROCEDURE obj_add4
+END PROCEDURE obj_Add4
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add5
+MODULE PROCEDURE obj_Add5
IF (SIZE(VALUE) .EQ. 1) THEN
obj%val(nodenum) = obj%val(nodenum) + scale * VALUE(1)
RETURN
END IF
obj%val(nodenum) = obj%val(nodenum) + scale * VALUE
-END PROCEDURE obj_add5
+END PROCEDURE obj_Add5
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add6
-obj%val(istart:iend:stride) = obj%val(istart:iend:stride) &
- + scale * VALUE
-END PROCEDURE obj_add6
+MODULE PROCEDURE obj_Add6
+! obj%val(istart:iend:stride) = obj%val(istart:iend:stride) + scale * VALUE
+REAL(DFP) :: aval(1)
+INTEGER(I4B) :: N
+aval(1) = VALUE
+N = INT((iend - istart + stride) / stride)
+CALL F77_AXPY(N=N, A=scale, X=aval, INCX=0_I4B, Y=obj%val(istart:), &
+ INCY=stride)
+END PROCEDURE obj_Add6
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add7
-obj%val(istart:iend:stride) = obj%val(istart:iend:stride) &
- + scale * VALUE
-END PROCEDURE obj_add7
+MODULE PROCEDURE obj_Add7
+! obj%val(istart:iend:stride) = obj%val(istart:iend:stride) + scale * VALUE
+INTEGER(I4B) :: N
+
+N = SIZE(VALUE)
+CALL F77_AXPY(N=N, A=scale, X=VALUE, INCX=1_I4B, Y=obj%val(istart:), &
+ INCY=stride)
+END PROCEDURE obj_Add7
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add8
+MODULE PROCEDURE obj_Add8
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, conversion=conversion)
-END PROCEDURE obj_add8
+END PROCEDURE obj_Add8
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add9
-CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, scale=scale)
-END PROCEDURE obj_add9
+MODULE PROCEDURE obj_Add9
+CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
+ scale=scale)
+END PROCEDURE obj_Add9
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add10
+MODULE PROCEDURE obj_Add10
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, idof=idof)
-END PROCEDURE obj_add10
+END PROCEDURE obj_Add10
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add11
+MODULE PROCEDURE obj_Add11
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
scale=scale, idof=idof)
-END PROCEDURE obj_add11
+END PROCEDURE obj_Add11
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add12
+MODULE PROCEDURE obj_Add12
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, idof=idof, ivar=ivar)
-END PROCEDURE obj_add12
+END PROCEDURE obj_Add12
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add13
+MODULE PROCEDURE obj_Add13
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
scale=scale, idof=idof, ivar=ivar)
-END PROCEDURE obj_add13
+END PROCEDURE obj_Add13
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add14
+MODULE PROCEDURE obj_Add14
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add14
+END PROCEDURE obj_Add14
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add15
+MODULE PROCEDURE obj_Add15
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add15
+END PROCEDURE obj_Add15
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add16
+MODULE PROCEDURE obj_Add16
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add16
+END PROCEDURE obj_Add16
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add17
+MODULE PROCEDURE obj_Add17
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add17
+END PROCEDURE obj_Add17
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add18
+MODULE PROCEDURE obj_Add18
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add18
+END PROCEDURE obj_Add18
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add19
+MODULE PROCEDURE obj_Add19
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add19
+END PROCEDURE obj_Add19
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add20
+MODULE PROCEDURE obj_Add20
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale)
-END PROCEDURE obj_add20
+END PROCEDURE obj_Add20
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add21
+MODULE PROCEDURE obj_Add21
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, idof=idof)
-END PROCEDURE obj_add21
+END PROCEDURE obj_Add21
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add22
+MODULE PROCEDURE obj_Add22
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, idof=idof)
-END PROCEDURE obj_add22
+END PROCEDURE obj_Add22
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add23
+MODULE PROCEDURE obj_Add23
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add23
+END PROCEDURE obj_Add23
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add24
+MODULE PROCEDURE obj_Add24
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add24
+END PROCEDURE obj_Add24
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add25
+MODULE PROCEDURE obj_Add25
CALL DOF_Add(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
scale=scale, ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_add25
+END PROCEDURE obj_Add25
!----------------------------------------------------------------------------
! add
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_add26
-obj%val = obj%val + scale * VALUE%val
-END PROCEDURE obj_add26
+MODULE PROCEDURE obj_Add26
+! obj%val = obj%val + scale * VALUE%val
+CALL F95_AXPY(A=scale, X=VALUE%val, Y=obj%val)
+END PROCEDURE obj_Add26
+
+!----------------------------------------------------------------------------
+! add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add27
+INTEGER(I4B) :: tdof, s(3), idof
+
+tdof = .tdof.dofobj
+
+DO idof = 1, tdof
+ s = GetNodeLoc(obj=dofobj, idof=idof)
+ CALL obj_Add7(obj=obj, istart=s(1), iend=s(2), stride=s(3), scale=scale, &
+ VALUE=VALUE(:, idof))
+END DO
+
+END PROCEDURE obj_Add27
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add28
+INTEGER(I4B) :: s(3)
+s = GetNodeLoc(obj=dofobj, idof=idof)
+CALL obj_Add7(obj=obj, istart=s(1), iend=s(2), stride=s(3), scale=scale, &
+ VALUE=VALUE)
+END PROCEDURE obj_Add28
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add29
+INTEGER(I4B) :: s1(3), s2(3)
+INTEGER(I4B) :: N
+
+s1 = GetNodeLoc(obj=dofobj1, idof=idof1)
+s2 = GetNodeLoc(obj=dofobj2, idof=idof2)
+
+N = (s1(2) - s1(1) + s1(3)) / s1(3)
+
+CALL F77_AXPY(N=N, A=scale, X=obj2%val(s2(1):), INCX=s2(3), &
+ Y=obj1%val(s1(1):), INCY=s1(3))
+END PROCEDURE obj_Add29
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add30
+INTEGER(I4B) :: ii, jj
+DO ii = istart, iend, stride
+ jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii)
+ obj%val(jj) = obj%val(jj) + scale * VALUE
+END DO
+END PROCEDURE obj_Add30
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add31
+INTEGER(I4B) :: ii, jj
+DO ii = istart, iend, stride
+ jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii)
+ obj%val(jj) = obj%val(jj) + scale * VALUE((ii - istart + stride) / stride)
+END DO
+END PROCEDURE obj_Add31
+
+!----------------------------------------------------------------------------
+! Add
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Add32
+INTEGER(I4B) :: tsize
+tsize = (iend - istart + stride) / stride
+CALL F77_AXPY(N=tsize, A=scale, X=VALUE(istart_value:), INCX=stride_value, &
+ Y=obj%val(istart:), INCY=stride)
+! !$OMP PARALLEL DO PRIVATE(ii)
+! DO ii = 1, tsize
+! obj%val(istart+(stride-1)*ii) = value(istart_value+(stride_value-1)*ii)
+! END DO
+! !$OMP END PARALLEL DO
+END PROCEDURE obj_Add32
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
END SUBMODULE Methods
diff --git a/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90
index 143d5c11a..071dd5fe3 100644
--- a/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90
+++ b/src/submodules/RealVector/src/RealVector_GetMethods@Methods.F90
@@ -17,7 +17,7 @@
!> author: Vikas Sharma, Ph. D.
! date: 25 Feb 2021
-! summary: This submodule contains get methods of [[RealVector_]]
+! summary: This submodule contains Get methods of [[RealVector_]]
SUBMODULE(RealVector_GetMethods) Methods
USE DOF_Method, ONLY: GetNodeLoc, DOF_GetIndex => GetIndex
@@ -32,41 +32,43 @@
USE RealVector_ConstructorMethods, ONLY: RealVector_Size => Size
+USE SafeSizeUtility, ONLY: SafeSize
+
IMPLICIT NONE
CONTAINS
!----------------------------------------------------------------------------
-! getPointer
+! GetPointer
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_getPointer1
+MODULE PROCEDURE obj_GetPointer1
val => obj%val
-END PROCEDURE obj_getPointer1
+END PROCEDURE obj_GetPointer1
!----------------------------------------------------------------------------
-! getPointer
+! GetPointer
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_getPointer2
+MODULE PROCEDURE obj_GetPointer2
INTEGER(I4B) :: s(3)
s = GetNodeLoc(obj=dofobj, idof=idof)
val => obj%val(s(1):s(2):s(3))
-END PROCEDURE obj_getPointer2
+END PROCEDURE obj_GetPointer2
!----------------------------------------------------------------------------
! IndexOf
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_getIndex1
+MODULE PROCEDURE obj_GetIndex1
Ans = MINLOC(ABS(obj%val - VALUE), 1)
-END PROCEDURE obj_getIndex1
+END PROCEDURE obj_GetIndex1
!----------------------------------------------------------------------------
! IndexOf
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_getIndex2
+MODULE PROCEDURE obj_GetIndex2
! Ans = MINLOC( ABS( obj%val - Value ), 1 )
INTEGER(I4B) :: i, j, m
LOGICAL(LGT), ALLOCATABLE :: Search(:)
@@ -87,7 +89,7 @@
END IF
END DO
END DO
-END PROCEDURE obj_getIndex2
+END PROCEDURE obj_GetIndex2
!----------------------------------------------------------------------------
! isPresent
@@ -133,122 +135,162 @@
END PROCEDURE obj_isPresent2
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get1
-IF (ALLOCATED(obj%val)) THEN
- ans = obj%val
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get1
+MODULE PROCEDURE obj_Get1
+INTEGER(I4B) :: tsize, ii
+tsize = SafeSize(obj%val)
+ALLOCATE (ans(tsize))
+
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = INT(obj%val(ii), kind=I4B)
+END DO
+END PROCEDURE obj_Get1
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get2
-IF (ALLOCATED(obj%val)) THEN
- ans = obj%val(nodenum)
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get2
+MODULE PROCEDURE obj_Get2
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(nodenum)
+ALLOCATE (ans(tsize))
+
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = INT(obj%val(nodenum(ii)), kind=I4B)
+END DO
+END PROCEDURE obj_Get2
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get3
-IF (ALLOCATED(obj%val)) THEN
- ans = obj%val(iStart:iEnd:Stride)
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get3
+MODULE PROCEDURE obj_Get3
+INTEGER(I4B) :: tsize, ii, jj
+
+tsize = 1_I4B + (iend - istart) / stride
+ALLOCATE (ans(tsize))
+
+jj = 0
+
+DO ii = istart, iend, stride
+ jj = jj + 1
+ ans(jj) = INT(obj%val(ii), kind=I4B)
+END DO
+END PROCEDURE obj_Get3
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get4a
-IF (ALLOCATED(obj%val)) THEN
- ans = obj
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get4a
+MODULE PROCEDURE obj_Get4a
+INTEGER(I4B) :: tsize, ii
+tsize = SafeSize(obj%val)
+ALLOCATE (ans(tsize))
-MODULE PROCEDURE obj_get4b
-IF (ALLOCATED(obj%val)) THEN
- ans = obj
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get4b
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = REAL(obj%val(ii), kind=REAL32)
+END DO
+
+END PROCEDURE obj_Get4a
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get5a
-IF (ALLOCATED(obj%val)) THEN
- CALL Reallocate(ans, SIZE(nodenum))
- ans = obj%val(nodenum)
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get5a
+MODULE PROCEDURE obj_Get4b
+INTEGER(I4B) :: tsize, ii
+tsize = SafeSize(obj%val)
+ALLOCATE (ans(tsize))
-MODULE PROCEDURE obj_get5b
-IF (ALLOCATED(obj%val)) THEN
- CALL Reallocate(ans, SIZE(nodenum))
- ans = obj%val(nodenum)
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get5b
+DO CONCURRENT(ii=1:tsize)
+ ans(ii) = REAL(obj%val(ii), kind=REAL64)
+END DO
+END PROCEDURE obj_Get4b
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get6
-IF (ALLOCATED(obj%val)) THEN
- ans = obj%val(iStart:iEnd:Stride)
-ELSE
- ALLOCATE (ans(0))
-END IF
-END PROCEDURE obj_get6
+MODULE PROCEDURE obj_Get5a
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(nodenum)
+ALLOCATE (ans(tsize))
+
+DO ii = 1, tsize
+ ans(ii) = REAL(obj%val(nodenum(ii)), kind=REAL32)
+END DO
+
+END PROCEDURE obj_Get5a
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get7
+MODULE PROCEDURE obj_Get5b
+INTEGER(I4B) :: tsize, ii
+
+tsize = SIZE(nodenum)
+ALLOCATE (ans(tsize))
+
+DO ii = 1, tsize
+ ans(ii) = REAL(obj%val(nodenum(ii)), kind=REAL64)
+END DO
+END PROCEDURE obj_Get5b
+
+!----------------------------------------------------------------------------
+! Get
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get6
+INTEGER(I4B) :: tsize, ii, jj
+
+tsize = 1_I4B + (iend - istart) / stride
+ALLOCATE (ans(tsize))
+
+jj = 0
+
+DO ii = istart, iend, stride
+ jj = jj + 1
+ ans(jj) = obj%val(ii)
+END DO
+
+END PROCEDURE obj_Get6
+
+!----------------------------------------------------------------------------
+! Get
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get7
INTEGER(I4B) :: N, i, tNodes, r1, r2
+
N = SIZE(obj)
tNodes = 0
DO i = 1, N
tNodes = tNodes + RealVector_SIZE(obj(i))
END DO
+
ALLOCATE (val(tNodes))
tNodes = 0
r1 = 0
r2 = 0
+
DO i = 1, N
r1 = r2 + 1
r2 = r2 + RealVector_SIZE(obj(i))
val(r1:r2) = obj(i)%val
END DO
-END PROCEDURE obj_get7
+
+END PROCEDURE obj_Get7
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get8
+MODULE PROCEDURE obj_Get8
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
M = SIZE(nodenum)
@@ -256,27 +298,27 @@
DO i = 1, N
val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum)
END DO
-END PROCEDURE obj_get8
+END PROCEDURE obj_Get8
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get9
+MODULE PROCEDURE obj_Get9
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
-M = 1 + (iEnd - iStart) / Stride
+M = 1 + (iend - istart) / stride
ALLOCATE (val(M * N))
DO i = 1, N
- val((i - 1) * M + 1:i * M) = obj(i)%val(iStart:iEnd:Stride)
+ val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride)
END DO
-END PROCEDURE obj_get9
+END PROCEDURE obj_Get9
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get10a
+MODULE PROCEDURE obj_Get10a
INTEGER(I4B) :: N, i, tNodes, r1, r2
N = SIZE(obj)
tNodes = 0
@@ -289,8 +331,13 @@
r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val)
val(r1:r2) = obj(i)%val
END DO
-END PROCEDURE obj_get10a
-MODULE PROCEDURE obj_get10b
+END PROCEDURE obj_Get10a
+
+!----------------------------------------------------------------------------
+! Get
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get10b
INTEGER(I4B) :: N, i, tNodes, r1, r2
N = SIZE(obj)
tNodes = 0
@@ -303,13 +350,13 @@
r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val)
val(r1:r2) = obj(i)%val
END DO
-END PROCEDURE obj_get10b
+END PROCEDURE obj_Get10b
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get11a
+MODULE PROCEDURE obj_Get11a
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
M = SIZE(nodenum)
@@ -317,9 +364,13 @@
DO i = 1, N
val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum)
END DO
-END PROCEDURE obj_get11a
+END PROCEDURE obj_Get11a
+
+!----------------------------------------------------------------------------
+! Get
+!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get11b
+MODULE PROCEDURE obj_Get11b
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
M = SIZE(nodenum)
@@ -327,127 +378,132 @@
DO i = 1, N
val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum)
END DO
-END PROCEDURE obj_get11b
+END PROCEDURE obj_Get11b
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get12a
+MODULE PROCEDURE obj_Get12a
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
-M = 1 + (iEnd - iStart) / Stride
+M = 1 + (iend - istart) / stride
ALLOCATE (val(M * N))
DO i = 1, N
- val((i - 1) * M + 1:i * M) = obj(i)%val(iStart:iEnd:Stride)
+ val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride)
END DO
-END PROCEDURE obj_get12a
-MODULE PROCEDURE obj_get12b
+END PROCEDURE obj_Get12a
+
+!----------------------------------------------------------------------------
+! Get
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get12b
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
-M = 1 + (iEnd - iStart) / Stride
+M = 1 + (iend - istart) / stride
ALLOCATE (val(M * N))
DO i = 1, N
- val((i - 1) * M + 1:i * M) = obj(i)%val(iStart:iEnd:Stride)
+ val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride)
END DO
-END PROCEDURE obj_get12b
+END PROCEDURE obj_Get12b
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get13
-val = get(obj=obj, dataType=1.0_DFP)
-END PROCEDURE obj_get13
+MODULE PROCEDURE obj_Get13
+val = Get(obj=obj, dataType=1.0_DFP)
+END PROCEDURE obj_Get13
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get14
-val = get(obj=obj, nodenum=nodenum, dataType=1.0_DFP)
-END PROCEDURE obj_get14
+MODULE PROCEDURE obj_Get14
+val = Get(obj=obj, nodenum=nodenum, dataType=1.0_DFP)
+END PROCEDURE obj_Get14
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get15
-val = get(obj=obj, istart=istart, iend=iend, stride=stride, &
+MODULE PROCEDURE obj_Get15
+val = Get(obj=obj, istart=istart, iend=iend, stride=stride, &
& dataType=1.0_DFP)
-END PROCEDURE obj_get15
+END PROCEDURE obj_Get15
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get16
-val = get(obj=obj, nodenum=nodenum, dataType=1.0_DFP)
-END PROCEDURE obj_get16
+MODULE PROCEDURE obj_Get16
+val = Get(obj=obj, nodenum=nodenum, dataType=1.0_DFP)
+END PROCEDURE obj_Get16
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get17
-val = get(obj=obj, istart=istart, iend=iend, stride=stride, &
+MODULE PROCEDURE obj_Get17
+val = Get(obj=obj, istart=istart, iend=iend, stride=stride, &
& dataType=1.0_DFP)
-END PROCEDURE obj_get17
+END PROCEDURE obj_Get17
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get18a
+MODULE PROCEDURE obj_Get18a
val = obj%val(nodenum)
-END PROCEDURE obj_get18a
+END PROCEDURE obj_Get18a
-MODULE PROCEDURE obj_get18b
+MODULE PROCEDURE obj_Get18b
val = obj%val(nodenum)
-END PROCEDURE obj_get18b
+END PROCEDURE obj_Get18b
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get19
+MODULE PROCEDURE obj_Get19
IF (ALLOCATED(obj%val)) THEN
ans = obj
ELSE
ALLOCATE (ans(0))
END IF
-END PROCEDURE obj_get19
+END PROCEDURE obj_Get19
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get20
+MODULE PROCEDURE obj_Get20
IF (ALLOCATED(obj%val)) THEN
CALL Reallocate(ans, SIZE(nodenum))
CALL COPY(Y=ans, X=obj%val(nodenum))
ELSE
ALLOCATE (ans(0))
END IF
-END PROCEDURE obj_get20
+END PROCEDURE obj_Get20
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get21
+MODULE PROCEDURE obj_Get21
IF (ALLOCATED(obj%val)) THEN
- ans = obj%val(iStart:iEnd:Stride)
+ ans = obj%val(istart:iend:stride)
ELSE
ALLOCATE (ans(0))
END IF
-END PROCEDURE obj_get21
+END PROCEDURE obj_Get21
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get22
+MODULE PROCEDURE obj_Get22
INTEGER(I4B) :: N, i, tNodes, r1, r2
N = SIZE(obj)
tNodes = 0
@@ -460,13 +516,13 @@
r1 = r2 + 1; r2 = r2 + SIZE(obj(i)%val)
val(r1:r2) = obj(i)%val
END DO
-END PROCEDURE obj_get22
+END PROCEDURE obj_Get22
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get23
+MODULE PROCEDURE obj_Get23
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
M = SIZE(nodenum)
@@ -474,56 +530,66 @@
DO i = 1, N
val((i - 1) * M + 1:i * M) = obj(i)%val(nodenum)
END DO
-END PROCEDURE obj_get23
+END PROCEDURE obj_Get23
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get24
+MODULE PROCEDURE obj_Get24
INTEGER(I4B) :: N, i, M
N = SIZE(obj)
-M = 1 + (iEnd - iStart) / Stride
+M = 1 + (iend - istart) / stride
ALLOCATE (val(M * N))
DO i = 1, N
- val((i - 1) * M + 1:i * M) = obj(i)%val(iStart:iEnd:Stride)
+ val((i - 1) * M + 1:i * M) = obj(i)%val(istart:iend:stride)
END DO
-END PROCEDURE obj_get24
+END PROCEDURE obj_Get24
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get25
+MODULE PROCEDURE obj_Get25
ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, &
- & ivar=ivar, idof=idof))
-END PROCEDURE obj_get25
+ ivar=ivar, idof=idof))
+END PROCEDURE obj_Get25
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get26
+MODULE PROCEDURE obj_Get26
ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, &
- & ivar=ivar, idof=idof))
-END PROCEDURE obj_get26
+ ivar=ivar, idof=idof))
+END PROCEDURE obj_Get26
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get27
+MODULE PROCEDURE obj_Get27
ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar))
-END PROCEDURE obj_get27
+END PROCEDURE obj_Get27
!----------------------------------------------------------------------------
-! get
+! Get
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_get28
+MODULE PROCEDURE obj_Get28
ans = obj%val(DOF_GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, &
spacecompo=spacecompo, timecompo=timecompo))
-END PROCEDURE obj_get28
+END PROCEDURE obj_Get28
+
+!----------------------------------------------------------------------------
+! Get
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Get29
+INTEGER(I4B) :: s(3)
+s = GetNodeLoc(obj=dofobj, idof=idof)
+ans = Get(obj=obj, istart=s(1), iend=s(2), stride=s(3), dataType=1.0_DFP)
+END PROCEDURE obj_Get29
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90
index 845aa07e9..9ca4e0181 100644
--- a/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90
+++ b/src/submodules/RealVector/src/RealVector_GetValueMethods@Methods.F90
@@ -30,6 +30,10 @@
USE F95_BLAS, ONLY: COPY
+USE F77_BLAS, ONLY: F77_Copy
+
+USE RealVector_SetMethods, ONLY: Set
+
IMPLICIT NONE
CONTAINS
@@ -38,11 +42,7 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue1
-INTEGER(I4B) :: ii, jj
-DO CONCURRENT(ii=istart:iend:stride)
- jj = INT((ii - istart + stride) / stride)
- VALUE%val(jj) = obj%val(ii)
-END DO
+CALL Set(obj=VALUE, VALUE=obj%val, istart=istart, iend=iend, stride=stride)
END PROCEDURE obj_GetValue1
!----------------------------------------------------------------------------
@@ -52,7 +52,7 @@
MODULE PROCEDURE obj_GetValue2
INTEGER(I4B) :: s(3)
s = GetNodeLoc(obj=dofobj, idof=idof)
-CALL GetValue(obj=obj, VALUE=VALUE, istart=s(1), iend=s(2), stride=s(3))
+CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3))
END PROCEDURE obj_GetValue2
!----------------------------------------------------------------------------
@@ -63,7 +63,7 @@
INTEGER(I4B) :: s(3)
s = GetNodeLoc(obj=dofobj, &
idof=GetIDOF(obj=dofobj, ivar=ivar, idof=idof))
-CALL GetValue(obj=obj, VALUE=VALUE, istart=s(1), iend=s(2), stride=s(3))
+CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3))
END PROCEDURE obj_GetValue3
!----------------------------------------------------------------------------
@@ -75,10 +75,10 @@
s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, &
ivar=ivar, &
- spacecompo=spacecompo, &
- timecompo=timecompo))
+ spaceCompo=spaceCompo, &
+ timeCompo=timeCompo))
-CALL GetValue(obj=obj, VALUE=VALUE, istart=s(1), iend=s(2), stride=s(3))
+CALL Set(obj=VALUE, VALUE=obj%val, istart=s(1), iend=s(2), stride=s(3))
END PROCEDURE obj_GetValue4
!----------------------------------------------------------------------------
@@ -86,16 +86,8 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue5
-INTEGER(I4B) :: p(3), s(3), ii, jj
-
-s = GetNodeLoc(obj=dofobj, idof=idofobj)
-p = GetNodeLoc(obj=dofvalue, idof=idofvalue)
-
-DO CONCURRENT(ii=s(1):s(2):s(3))
- jj = INT((ii - s(1) + s(3)) / s(3))
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
-END DO
-
+CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=idofvalue, &
+ obj2=obj, dofobj2=dofobj, idof2=idofobj)
END PROCEDURE obj_GetValue5
!----------------------------------------------------------------------------
@@ -103,20 +95,11 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue6
-INTEGER(I4B) :: p(3), s(3), ii, jj, kk, ll
-
-ll = SIZE(idofobj)
-
-DO CONCURRENT(kk=1:ll)
-
- s = GetNodeLoc(obj=dofobj, idof=idofobj(kk))
- p = GetNodeLoc(obj=dofvalue, idof=idofvalue(kk))
-
- DO ii = s(1), s(2), s(3)
- jj = INT((ii - s(1) + s(3)) / s(3))
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
- END DO
+INTEGER(I4B) :: ii
+DO ii = 1, SIZE(idofobj)
+ CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=idofvalue(ii), &
+ obj2=obj, dofobj2=dofobj, idof2=idofobj(ii))
END DO
END PROCEDURE obj_GetValue6
@@ -126,20 +109,11 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue7
-INTEGER(I4B) :: p(3), s(3), ii, jj
-
-s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, &
- ivar=ivarobj, idof=idofobj))
-
-p = GetNodeLoc(obj=dofvalue, idof=GetIDOF(obj=dofvalue, &
- ivar=ivarvalue, &
- idof=idofvalue))
-
-DO CONCURRENT(ii=s(1):s(2):s(3))
- jj = INT((ii - s(1) + s(3)) / s(3))
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
-END DO
-
+INTEGER(I4B) :: global_idofobj, global_idofvalue
+global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, idof=idofobj)
+global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, idof=idofvalue)
+CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, &
+ obj2=obj, dofobj2=dofobj, idof2=global_idofobj)
END PROCEDURE obj_GetValue7
!----------------------------------------------------------------------------
@@ -147,25 +121,13 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue8
-INTEGER(I4B) :: p(3), s(3), ii, jj, kk
-
-DO kk = 1, SIZE(idofobj)
-
- s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, &
- ivar=ivarobj, &
- idof=idofobj(kk)))
-
- p = GetNodeLoc(obj=dofvalue, idof=GetIDOF(obj=dofvalue, &
- ivar=ivarvalue, &
- idof=idofvalue(kk)))
-
- jj = 0
-
- DO ii = s(1), s(2), s(3)
- jj = jj + 1
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
- END DO
+INTEGER(I4B) :: global_idofobj, global_idofvalue, ii
+DO ii = 1, SIZE(idofobj)
+ global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, idof=idofobj(ii))
+ global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, idof=idofvalue(ii))
+ CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, &
+ obj2=obj, dofobj2=dofobj, idof2=global_idofobj)
END DO
END PROCEDURE obj_GetValue8
@@ -175,24 +137,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue9
-INTEGER(I4B) :: p(3), s(3), ii, jj
+INTEGER(I4B) :: global_idofobj, global_idofvalue
-s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, &
- ivar=ivarobj, &
- spacecompo=spacecompoobj, &
- timecompo=timecompoobj))
-
-p = GetNodeLoc(obj=dofvalue, idof=GetIDOF(obj=dofvalue, &
- ivar=ivarvalue, &
- spacecompo=spacecompovalue, &
- timecompo=timecompovalue))
+global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, spaceCompo=spaceCompoObj, &
+ timeCompo=timeCompoObj)
-jj = 0
+global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, &
+ spaceCompo=spaceCompoValue, timeCompo=timeCompoValue)
-DO ii = s(1), s(2), s(3)
- jj = jj + 1
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
-END DO
+CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, &
+ obj2=obj, dofobj2=dofobj, idof2=global_idofobj)
END PROCEDURE obj_GetValue9
@@ -201,27 +155,17 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue10
-INTEGER(I4B) :: p(3), s(3), ii, jj, kk
-
-DO kk = 1, SIZE(timecompoobj)
-
- s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, &
- ivar=ivarobj, &
- spacecompo=spacecompoobj, &
- timecompo=timecompoobj(kk)))
+INTEGER(I4B) :: global_idofobj, global_idofvalue, ii
- p = GetNodeLoc(obj=dofvalue, idof=GetIDOF(obj=dofvalue, &
- ivar=ivarvalue, &
- spacecompo=spacecompovalue, &
- timecompo=timecompovalue(kk)))
+DO ii = 1, SIZE(timeCompoObj)
+ global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, &
+ spaceCompo=spaceCompoObj, timeCompo=timeCompoObj(ii))
- jj = 0
-
- DO ii = s(1), s(2), s(3)
- jj = jj + 1
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
- END DO
+ global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, &
+ spaceCompo=spaceCompoValue, timeCompo=timeCompoValue(ii))
+ CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, &
+ obj2=obj, dofobj2=dofobj, idof2=global_idofobj)
END DO
END PROCEDURE obj_GetValue10
@@ -231,26 +175,18 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE obj_GetValue11
-INTEGER(I4B) :: p(3), s(3), ii, jj, kk
+INTEGER(I4B) :: global_idofobj, global_idofvalue, ii
-DO kk = 1, SIZE(spacecompoobj)
+DO ii = 1, SIZE(spaceCompoObj)
- s = GetNodeLoc(obj=dofobj, idof=GetIDOF(obj=dofobj, &
- ivar=ivarobj, &
- spacecompo=spacecompoobj(kk), &
- timecompo=timecompoobj))
+ global_idofobj = GetIDOF(obj=dofobj, ivar=ivarobj, &
+ spaceCompo=spaceCompoObj(ii), timeCompo=timeCompoObj)
- p = GetNodeLoc(obj=dofvalue, idof=GetIDOF(obj=dofvalue, &
- ivar=ivarvalue, &
- spacecompo=spacecompovalue(kk), &
- timecompo=timecompovalue))
+ global_idofvalue = GetIDOF(obj=dofvalue, ivar=ivarvalue, &
+ spaceCompo=spaceCompoValue(ii), timeCompo=timeCompoValue)
- jj = 0
-
- DO ii = s(1), s(2), s(3)
- jj = jj + 1
- VALUE%val(p(1) + (jj - 1) * p(3)) = obj%val(ii)
- END DO
+ CALL Set(obj1=VALUE, dofobj1=dofvalue, idof1=global_idofvalue, &
+ obj2=obj, dofobj2=dofobj, idof2=global_idofobj)
END DO
@@ -364,7 +300,7 @@
MODULE PROCEDURE obj_GetValue18
VALUE = obj%val(GetIndex(obj=dofobj, nodenum=nodenum, ivar=ivar, &
- spacecompo=spacecompo, timecompo=timecompo))
+ spaceCompo=spaceCompo, timeCompo=timeCompo))
END PROCEDURE obj_GetValue18
!----------------------------------------------------------------------------
@@ -373,8 +309,8 @@
MODULE PROCEDURE obj_GetValue_18
INTEGER(I4B) :: idof
-idof = GetIDOF(obj=dofobj, ivar=ivar, spacecompo=spacecompo, &
- timecompo=timecompo)
+idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, &
+ timeCompo=timeCompo)
CALL DOF_GetValue_(v=VALUE, val=obj%val, obj=dofobj, idof=idof, &
nodenum=nodenum, tsize=tsize)
END PROCEDURE obj_GetValue_18
@@ -430,8 +366,8 @@
MODULE PROCEDURE obj_GetValue21
INTEGER(I4B) :: global_idof
-global_idof = GetIDOF(obj=dofobj, ivar=ivar, spacecompo=spacecompo, &
- timecompo=timecompo)
+global_idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, &
+ timeCompo=timeCompo)
CALL GetValue(obj=obj, dofobj=dofobj, idof=global_idof, &
VALUE=VALUE)
END PROCEDURE obj_GetValue21
@@ -442,8 +378,8 @@
MODULE PROCEDURE obj_GetValue_21
INTEGER(I4B) :: global_idof
-global_idof = GetIDOF(obj=dofobj, ivar=ivar, spacecompo=spacecompo, &
- timecompo=timecompo)
+global_idof = GetIDOF(obj=dofobj, ivar=ivar, spaceCompo=spaceCompo, &
+ timeCompo=timeCompo)
CALL GetValue_(obj=obj, dofobj=dofobj, idof=global_idof, &
VALUE=VALUE, tsize=tsize)
END PROCEDURE obj_GetValue_21
@@ -493,10 +429,96 @@
! GetValue
!----------------------------------------------------------------------------
+MODULE PROCEDURE obj_GetValue_24
+INTEGER(I4B) :: jj
+
+SELECT CASE (storageFMT)
+
+CASE (DOF_FMT)
+ ncol = SIZE(idof)
+
+ DO jj = 1, ncol
+ CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof(jj:jj), nodenum=nodenum, &
+ VALUE=VALUE(:, jj), tsize=nrow, storageFMT=dofobj%storageFMT)
+ END DO
+
+CASE (NODES_FMT)
+ ncol = SIZE(nodenum)
+
+ DO jj = 1, ncol
+ CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, nodenum=nodenum(jj:jj), &
+ VALUE=VALUE(:, jj), tsize=nrow, storageFMT=dofobj%storageFMT)
+ END DO
+
+END SELECT
+
+END PROCEDURE obj_GetValue_24
+
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE obj_GetValue24
CALL COPY(Y=VALUE%val, X=obj%val)
END PROCEDURE obj_GetValue24
+!----------------------------------------------------------------------------
+! GetValue
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetValue_25
+INTEGER(I4B) :: jj
+
+SELECT CASE (storageFMT)
+
+CASE (DOF_FMT)
+ ncol = SIZE(idof)
+
+ DO jj = 1, ncol
+ CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof(jj), &
+ VALUE=VALUE(:, jj), tsize=nrow)
+ END DO
+
+CASE (NODES_FMT)
+ CALL GetValue_(obj=obj, dofobj=dofobj, idof=idof, VALUE=VALUE, &
+ nrow=nrow, ncol=ncol)
+
+END SELECT
+
+END PROCEDURE obj_GetValue_25
+
+!----------------------------------------------------------------------------
+! GetValue_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetValue_26
+INTEGER(I4B) :: ii
+tsize = SIZE(nodenum)
+DO ii = 1, tsize
+ VALUE(ii) = obj%val(nodenum(ii))
+END DO
+END PROCEDURE obj_GetValue_26
+
+!----------------------------------------------------------------------------
+! GetValue_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetValue_27
+tsize = (iend - istart + stride) / stride
+CALL F77_Copy(N=tsize, X=obj%val(istart:), INCX=stride, &
+ Y=VALUE, INCY=1_I4B)
+END PROCEDURE obj_GetValue_27
+
+!----------------------------------------------------------------------------
+! GetValue_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_GetValue_28
+tsize = (iend - istart + stride) / stride
+CALL F77_Copy(N=tsize, X=obj%val(istart:), INCX=stride, &
+ Y=VALUE(istart_value:), INCY=stride_value)
+END PROCEDURE obj_GetValue_28
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90 b/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90
index 8aefe9f4c..1e8678589 100644
--- a/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90
+++ b/src/submodules/RealVector/src/RealVector_SetMethods@Methods.F90
@@ -16,7 +16,9 @@
!
SUBMODULE(RealVector_SetMethods) Methods
-USE DOF_Method, ONLY: DOF_Set => Set
+USE DOF_Method, ONLY: DOF_Set => Set, &
+ OPERATOR(.tdof.), &
+ GetNodeLoc
USE F77_Blas, ONLY: F77_Copy
USE F95_Blas, ONLY: F95_Copy => Copy
IMPLICIT NONE
@@ -26,246 +28,335 @@
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set1
+MODULE PROCEDURE obj_Set1
REAL(DFP) :: aval(1)
INTEGER(I4B) :: N
aval(1) = VALUE
N = SIZE(obj%val)
CALL F77_Copy(N=N, X=aval, INCX=0_I4B, Y=obj%val, INCY=1_I4B)
-END PROCEDURE obj_set1
+END PROCEDURE obj_Set1
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set2
+MODULE PROCEDURE obj_Set2
CALL F95_Copy(X=VALUE, Y=obj%val)
-END PROCEDURE obj_set2
+END PROCEDURE obj_Set2
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set3
+MODULE PROCEDURE obj_Set3
obj%val(nodenum) = VALUE
-END PROCEDURE obj_set3
+END PROCEDURE obj_Set3
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set4
+MODULE PROCEDURE obj_Set4
obj%val(nodenum) = VALUE
-END PROCEDURE obj_set4
+END PROCEDURE obj_Set4
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set5
+MODULE PROCEDURE obj_Set5
IF (SIZE(VALUE) .EQ. 1) THEN
obj%val(nodenum) = VALUE(1)
RETURN
END IF
obj%val(nodenum) = VALUE
-END PROCEDURE obj_set5
+END PROCEDURE obj_Set5
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set6
+MODULE PROCEDURE obj_Set6
REAL(DFP) :: aval(1)
INTEGER(I4B) :: N
aval(1) = VALUE
N = INT((iend - istart + stride) / stride)
CALL F77_Copy(N=N, X=aval, INCX=0_I4B, Y=obj%val(istart:), &
INCY=stride)
-END PROCEDURE obj_set6
+END PROCEDURE obj_Set6
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set7
+MODULE PROCEDURE obj_Set7
INTEGER(I4B) :: N
N = SIZE(VALUE)
CALL F77_Copy(N=N, X=VALUE, INCX=1_I4B, Y=obj%val(istart:), &
INCY=stride)
-END PROCEDURE obj_set7
+END PROCEDURE obj_Set7
!----------------------------------------------------------------------------
! Set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set8
+MODULE PROCEDURE obj_Set8
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
conversion=conversion)
-END PROCEDURE obj_set8
+END PROCEDURE obj_Set8
!----------------------------------------------------------------------------
! Set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set9
+MODULE PROCEDURE obj_Set9
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE)
-END PROCEDURE obj_set9
+END PROCEDURE obj_Set9
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set10
+MODULE PROCEDURE obj_Set10
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
idof=idof)
-END PROCEDURE obj_set10
+END PROCEDURE obj_Set10
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set11
+MODULE PROCEDURE obj_Set11
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
idof=idof)
-END PROCEDURE obj_set11
+END PROCEDURE obj_Set11
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set12
+MODULE PROCEDURE obj_Set12
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
idof=idof, ivar=ivar)
-END PROCEDURE obj_set12
+END PROCEDURE obj_Set12
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set13
+MODULE PROCEDURE obj_Set13
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
idof=idof, ivar=ivar)
-END PROCEDURE obj_set13
+END PROCEDURE obj_Set13
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set14
+MODULE PROCEDURE obj_Set14
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set14
+END PROCEDURE obj_Set14
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set15
+MODULE PROCEDURE obj_Set15
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set15
+END PROCEDURE obj_Set15
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set16
+MODULE PROCEDURE obj_Set16
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set16
+END PROCEDURE obj_Set16
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set17
+MODULE PROCEDURE obj_Set17
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set17
+END PROCEDURE obj_Set17
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set18
+MODULE PROCEDURE obj_Set18
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set18
+END PROCEDURE obj_Set18
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set19
+MODULE PROCEDURE obj_Set19
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=[VALUE], &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set19
+END PROCEDURE obj_Set19
!----------------------------------------------------------------------------
! Set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set20
+MODULE PROCEDURE obj_Set20
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE)
-END PROCEDURE obj_set20
+END PROCEDURE obj_Set20
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set21
+MODULE PROCEDURE obj_Set21
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
idof=idof)
-END PROCEDURE obj_set21
+END PROCEDURE obj_Set21
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set22
+MODULE PROCEDURE obj_Set22
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, idof=idof)
-END PROCEDURE obj_set22
+END PROCEDURE obj_Set22
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set23
+MODULE PROCEDURE obj_Set23
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set23
+END PROCEDURE obj_Set23
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set24
+MODULE PROCEDURE obj_Set24
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set24
+END PROCEDURE obj_Set24
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set25
+MODULE PROCEDURE obj_Set25
CALL DOF_Set(vec=obj%val, obj=dofobj, nodenum=nodenum, VALUE=VALUE, &
ivar=ivar, spacecompo=spacecompo, timecompo=timecompo)
-END PROCEDURE obj_set25
+END PROCEDURE obj_Set25
!----------------------------------------------------------------------------
! set
!----------------------------------------------------------------------------
-MODULE PROCEDURE obj_set26
-obj%val = VALUE%val
-END PROCEDURE obj_set26
+MODULE PROCEDURE obj_Set26
+! obj%val = VALUE%val
+CALL F95_Copy(X=VALUE%val, Y=obj%val)
+END PROCEDURE obj_Set26
!----------------------------------------------------------------------------
-! set
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set27
+INTEGER(I4B) :: tdof, s(3), idof
+
+tdof = .tdof.dofobj
+
+DO idof = 1, tdof
+ s = GetNodeLoc(obj=dofobj, idof=idof)
+ CALL obj_Set7(obj=obj, istart=s(1), iend=s(2), stride=s(3), &
+ VALUE=VALUE(:, idof))
+END DO
+
+END PROCEDURE obj_Set27
+
+!----------------------------------------------------------------------------
+! Set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set28
+INTEGER(I4B) :: s(3)
+s = GetNodeLoc(obj=dofobj, idof=idof)
+CALL obj_Set7(obj=obj, istart=s(1), iend=s(2), stride=s(3), VALUE=VALUE)
+END PROCEDURE obj_Set28
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set29
+INTEGER(I4B) :: s1(3), s2(3)
+INTEGER(I4B) :: N
+
+s1 = GetNodeLoc(obj=dofobj1, idof=idof1)
+s2 = GetNodeLoc(obj=dofobj2, idof=idof2)
+
+N = (s1(2) - s1(1) + s1(3)) / s1(3)
+
+CALL F77_Copy(N=N, X=obj2%val(s2(1):), INCX=s2(3), Y=obj1%val(s1(1):), &
+ INCY=s1(3))
+END PROCEDURE obj_Set29
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set30
+INTEGER(I4B) :: ii, jj
+!$OMP PARALLEL DO PRIVATE(ii, jj)
+DO ii = istart, iend, stride
+ jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii)
+ obj%val(jj) = VALUE
+END DO
+!$OMP END PARALLEL DO
+END PROCEDURE obj_Set30
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set31
+INTEGER(I4B) :: ii, jj
+!$OMP PARALLEL DO PRIVATE(ii, jj)
+DO ii = istart, iend, stride
+ jj = GetNodeLoc(obj=dofobj, idof=idof, nodenum=ii)
+ obj%val(jj) = VALUE((ii - istart + stride) / stride)
+END DO
+!$OMP END PARALLEL DO
+END PROCEDURE obj_Set31
+
+!----------------------------------------------------------------------------
+! set
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Set32
+INTEGER(I4B) :: tsize
+tsize = (iend - istart + stride) / stride
+CALL F77_Copy(N=tsize, X=VALUE(istart_value:), INCX=stride_value, &
+ Y=obj%val(istart:), INCY=stride)
+! !$OMP PARALLEL DO PRIVATE(ii)
+! DO ii = 1, tsize
+! obj%val(istart+(stride-1)*ii) = value(istart_value+(stride_value-1)*ii)
+! END DO
+! !$OMP END PARALLEL DO
+END PROCEDURE obj_Set32
+
+!----------------------------------------------------------------------------
+!
!----------------------------------------------------------------------------
END SUBMODULE Methods
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_1.inc b/src/submodules/STConvectiveMatrix/src/STCM_1.inc
index 83bace805..8badb54d3 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_1.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_1.inc
@@ -45,7 +45,8 @@ PURE SUBROUTINE STCM_1a(ans, test, trial, term1, term2, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -95,7 +96,8 @@ PURE SUBROUTINE STCM_1b(ans, test, trial, term1, term2, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_10.inc b/src/submodules/STConvectiveMatrix/src/STCM_10.inc
index 7f4492b77..a91c471ef 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_10.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_10.inc
@@ -45,14 +45,15 @@ PURE SUBROUTINE STCM_10a(ans, test, trial, term1, term2, rho, c, opt)
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, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -100,14 +101,15 @@ PURE SUBROUTINE STCM_10b(ans, test, trial, term1, term2, rho, c, opt)
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, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_11.inc b/src/submodules/STConvectiveMatrix/src/STCM_11.inc
index afe947737..6a92007b5 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_11.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_11.inc
@@ -43,14 +43,14 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
if( opt .eq. 1 ) then
!!
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))
!!
@@ -59,7 +59,8 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -81,7 +82,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))
!!
@@ -90,7 +91,8 @@ PURE SUBROUTINE STCM_11a(ans, test, trial, term1, term2, rho, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -144,13 +146,13 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
if( opt .eq. 1 ) then
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))
!!
@@ -159,7 +161,8 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -180,7 +183,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))
!!
@@ -189,7 +192,8 @@ PURE SUBROUTINE STCM_11b(ans, test, trial, term1, term2, rho, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:, ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p,c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_12.inc b/src/submodules/STConvectiveMatrix/src/STCM_12.inc
index ffb27a1d8..d03ec6132 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_12.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_12.inc
@@ -46,14 +46,15 @@ PURE SUBROUTINE STCM_12a(ans, test, trial, term1, term2, rho, c, opt)
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, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -99,14 +100,15 @@ PURE SUBROUTINE STCM_12b(ans, test, trial, term1, term2, rho, c, opt)
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, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_13.inc b/src/submodules/STConvectiveMatrix/src/STCM_13.inc
index 6e5dfa2e7..c17547546 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_13.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_13.inc
@@ -40,12 +40,12 @@ PURE SUBROUTINE STCM_13a(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -104,12 +104,12 @@ PURE SUBROUTINE STCM_13b(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -168,12 +168,12 @@ PURE SUBROUTINE STCM_13c(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -232,12 +232,12 @@ PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -269,4 +269,3 @@ PURE SUBROUTINE STCM_13d(ans, test, trial, term1, term2, c, opt)
DEALLOCATE (m6, realval, vbar)
!!
END SUBROUTINE STCM_13d
-
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_14.inc b/src/submodules/STConvectiveMatrix/src/STCM_14.inc
index 20a7621fe..81d864d18 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_14.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_14.inc
@@ -40,12 +40,12 @@ PURE SUBROUTINE STCM_14a(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -104,12 +104,12 @@ PURE SUBROUTINE STCM_14b(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -168,12 +168,12 @@ PURE SUBROUTINE STCM_14c(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -232,12 +232,12 @@ PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt)
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -269,4 +269,3 @@ PURE SUBROUTINE STCM_14d(ans, test, trial, term1, term2, c, opt)
DEALLOCATE (m6, realval, vbar)
!!
END SUBROUTINE STCM_14d
-
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_15.inc b/src/submodules/STConvectiveMatrix/src/STCM_15.inc
index 6b86dda81..7ed27ea92 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_15.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_15.inc
@@ -44,13 +44,13 @@ PURE SUBROUTINE STCM_15a(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -113,13 +113,13 @@ PURE SUBROUTINE STCM_15b(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=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))
!!
@@ -182,13 +182,13 @@ PURE SUBROUTINE STCM_15c(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -251,13 +251,13 @@ PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -289,4 +289,3 @@ PURE SUBROUTINE STCM_15d(ans, test, trial, term1, term2, rho, c, &
DEALLOCATE (m6, realval, vbar, rhobar)
!!
END SUBROUTINE STCM_15d
-
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_16.inc b/src/submodules/STConvectiveMatrix/src/STCM_16.inc
index 06ac2870a..6b77ac369 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_16.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_16.inc
@@ -44,13 +44,13 @@ PURE SUBROUTINE STCM_16a(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -113,13 +113,13 @@ PURE SUBROUTINE STCM_16b(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -182,13 +182,13 @@ PURE SUBROUTINE STCM_16c(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -251,13 +251,13 @@ PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -289,4 +289,3 @@ PURE SUBROUTINE STCM_16d(ans, test, trial, term1, term2, rho, c, &
DEALLOCATE (m6, realval, vbar, rhobar)
!!
END SUBROUTINE STCM_16d
-
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_17.inc b/src/submodules/STConvectiveMatrix/src/STCM_17.inc
index 3f52946a9..de96d90a6 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_17.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_17.inc
@@ -46,14 +46,14 @@ PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
!!
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -62,7 +62,8 @@ PURE SUBROUTINE STCM_17a(ans, test, trial, term1, term2, rho, c, &
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -120,14 +121,14 @@ PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
!!
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -136,7 +137,8 @@ PURE SUBROUTINE STCM_17b(ans, test, trial, term1, term2, rho, c, &
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -194,14 +196,14 @@ PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
!!
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -210,7 +212,8 @@ PURE SUBROUTINE STCM_17c(ans, test, trial, term1, term2, rho, c, &
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -268,13 +271,13 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, &
!!
!! main
!!
- CALL GetInterpolation(obj=trial, interpol=vbar, val=c)
- CALL GetInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
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))
!!
@@ -283,7 +286,8 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, &
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFeVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -308,4 +312,3 @@ PURE SUBROUTINE STCM_17d(ans, test, trial, term1, term2, rho, c, &
DEALLOCATE (m6, realval, vbar, rhobar, p)
!!
END SUBROUTINE STCM_17d
-
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_2.inc b/src/submodules/STConvectiveMatrix/src/STCM_2.inc
index cb5ec15db..7f7db05cb 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_2.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_2.inc
@@ -41,7 +41,7 @@ PURE SUBROUTINE STCM_2a(ans, test, trial, term1, term2, c, opt)
!!
!! make c bar at ips and ipt
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
@@ -101,7 +101,7 @@ PURE SUBROUTINE STCM_2b(ans, test, trial, term1, term2, c, opt)
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_3.inc b/src/submodules/STConvectiveMatrix/src/STCM_3.inc
index 7ff2ee6e7..a8a274d3b 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_3.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_3.inc
@@ -43,7 +43,7 @@ PURE SUBROUTINE STCM_3a(ans, test, trial, term1, &
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
@@ -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))
!!
@@ -152,7 +152,7 @@ PURE SUBROUTINE STCM_3b(ans, test, trial, term1, &
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
@@ -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_4.inc b/src/submodules/STConvectiveMatrix/src/STCM_4.inc
index 24aeacc50..58913d9ea 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_4.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_4.inc
@@ -40,7 +40,7 @@ PURE SUBROUTINE STCM_4a(ans, test, trial, term1, term2, c, opt)
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
@@ -96,7 +96,7 @@ PURE SUBROUTINE STCM_4b(ans, test, trial, term1, term2, c, opt)
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_5.inc b/src/submodules/STConvectiveMatrix/src/STCM_5.inc
index 6eb81e2d8..d87a94409 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_5.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_5.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE STCM_5a(ans, test, trial, term1, term2, c, opt)
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
@@ -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))
!!
@@ -146,7 +146,7 @@ PURE SUBROUTINE STCM_5b(ans, test, trial, term1, term2, c, opt)
!! make c bar at ips and ipt
!!
IF (PRESENT(c)) THEN
- CALL GetInterpolation(obj=trial, val=c, interpol=cbar)
+ CALL GetInterpolation(obj=trial, val=c, ans=cbar)
ELSE
CALL Reallocate(cbar, SIZE(trial(1)%N, 2), SIZE(trial))
cbar = 1.0_DFP
@@ -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_6.inc b/src/submodules/STConvectiveMatrix/src/STCM_6.inc
index 700f7db54..9b93f3405 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_6.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_6.inc
@@ -48,7 +48,8 @@ PURE SUBROUTINE STCM_6a(ans, test, trial, term1, term2, c, projecton, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -100,7 +101,8 @@ PURE SUBROUTINE STCM_6b(ans, test, trial, term1, term2, c, projecton, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_7.inc b/src/submodules/STConvectiveMatrix/src/STCM_7.inc
index ac7faec21..5e13cc4ea 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))
!!
@@ -54,7 +54,8 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p,c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -75,7 +76,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))
!!
@@ -84,7 +85,8 @@ PURE SUBROUTINE STCM_7a(ans, test, trial, term1, term2, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -137,7 +139,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))
!!
@@ -146,7 +148,8 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
@@ -167,7 +170,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))
!!
@@ -176,7 +179,8 @@ PURE SUBROUTINE STCM_7b(ans, test, trial, term1, term2, c, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
DO b = 1, SIZE(m6, 6)
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_8.inc b/src/submodules/STConvectiveMatrix/src/STCM_8.inc
index 5aac726a1..28f777f99 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_8.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_8.inc
@@ -47,7 +47,8 @@ PURE SUBROUTINE STCM_8a(ans, test, trial, c, term1, term2, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -95,7 +96,8 @@ PURE SUBROUTINE STCM_8b(ans, test, trial, c, term1, term2, opt)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -109,4 +111,4 @@ PURE SUBROUTINE STCM_8b(ans, test, trial, c, term1, term2, opt)
!!
DEALLOCATE (IaJb, p, realval)
!!
-END SUBROUTINE STCM_8b
\ No newline at end of file
+END SUBROUTINE STCM_8b
diff --git a/src/submodules/STConvectiveMatrix/src/STCM_9.inc b/src/submodules/STConvectiveMatrix/src/STCM_9.inc
index 301ffc2e9..09162f556 100644
--- a/src/submodules/STConvectiveMatrix/src/STCM_9.inc
+++ b/src/submodules/STConvectiveMatrix/src/STCM_9.inc
@@ -42,14 +42,15 @@ PURE SUBROUTINE STCM_9a(ans, test, trial, term1, term2, rho, c, opt)
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, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p, c=c, &
+ crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
IaJb = IaJb + realval(ips) &
@@ -94,14 +95,14 @@ PURE SUBROUTINE STCM_9b(ans, test, trial, term1, term2, rho, c, opt)
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, val=rho, interpol=rhobar)
+ CALL GetInterpolation(obj=trial, val=rho, ans=rhobar)
!!
DO ipt = 1, SIZE(trial)
!!
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
& trial(ipt)%wt * trial(ipt)%jt * rhobar(:,ipt)
!!
- CALL GetProjectionOfdNTdXt(obj=test(ipt), cdNTdXt=p, val=c)
+ CALL GetProjectionOfdNTdXt(obj=test(ipt), ans=p, c=c, crank=TypeFEVariableVector)
!!
DO ips = 1, SIZE(realval)
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_1.inc b/src/submodules/STDiffusionMatrix/src/STDM_1.inc
index 62ab2a90f..a8c2985e5 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_1.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_1.inc
@@ -33,7 +33,7 @@ PURE SUBROUTINE STDM_1(ans, test, trial, k, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=k)
+ CALL getInterpolation(obj=trial, ans=kbar, val=k)
!!
CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
& SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_11.inc b/src/submodules/STDiffusionMatrix/src/STDM_11.inc
index 45d6b94cf..b6cbf4061 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_11.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_11.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE STDM_11a(ans, test, trial, k, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=k)
+ CALL getInterpolation(obj=trial, ans=kbar, val=k)
!!
nsd = trial(1)%refelem%nsd
!!
@@ -111,7 +111,7 @@ PURE SUBROUTINE STDM_11b(ans, test, trial, k, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=k)
+ CALL getInterpolation(obj=trial, ans=kbar, val=k)
!!
nsd = trial(1)%refelem%nsd
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_12.inc b/src/submodules/STDiffusionMatrix/src/STDM_12.inc
index 8c8e1ee34..210819e12 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_12.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_12.inc
@@ -39,7 +39,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=k)
+ CALL getInterpolation(obj=trial, ans=vbar, val=k)
!!
CALL Reallocate( &
& IJab, &
@@ -121,7 +121,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=k)
+ CALL getInterpolation(obj=trial, ans=vbar, val=k)
!!
CALL Reallocate( &
& IJab, &
@@ -178,4 +178,3 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
DEALLOCATE (realval, IJab, vbar, m6)
!!
END SUBROUTINE STDM_12b
-
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_13.inc b/src/submodules/STDiffusionMatrix/src/STDM_13.inc
index 07e8c1420..1ef4439f7 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_13.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_13.inc
@@ -48,8 +48,8 @@ PURE SUBROUTINE STDM_13a(ans, test, trial, c1, c2, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=c2bar, val=c2)
!!
nsd = trial(1)%refelem%nsd
!!
@@ -118,8 +118,8 @@ PURE SUBROUTINE STDM_13b(ans, test, trial, c1, c2, opt)
& SIZE(test(1)%T), &
& SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=c2bar, val=c2)
!!
nsd = trial(1)%refelem%nsd
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_14.inc b/src/submodules/STDiffusionMatrix/src/STDM_14.inc
index b4415905a..67f78aa00 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_14.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_14.inc
@@ -42,8 +42,8 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=cbar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=cbar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate( &
& IJab, &
@@ -128,8 +128,8 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=cbar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=cbar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate( &
& IJab, &
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_3.inc b/src/submodules/STDiffusionMatrix/src/STDM_3.inc
index e753853ac..984393b36 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_3.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_3.inc
@@ -35,7 +35,7 @@ PURE SUBROUTINE STDM_3(ans, test, trial, k, opt)
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, ans=kbar, val=k)
!!
nsd = trial(1)%refelem%nsd
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_5.inc b/src/submodules/STDiffusionMatrix/src/STDM_5.inc
index 392dec893..ab311cb44 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_5.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_5.inc
@@ -47,8 +47,8 @@ PURE SUBROUTINE STDM_5(ans, test, trial, c1, c2, opt)
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, ans=rhobar, val=c1)
+ CALL getInterpolation(obj=trial, ans=kbar, val=c2)
!!
nsd = trial(1)%refelem%nsd
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_6.inc b/src/submodules/STDiffusionMatrix/src/STDM_6.inc
index abb4efdb8..85b591ac1 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_6.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_6.inc
@@ -39,8 +39,8 @@ PURE SUBROUTINE STDM_6(ans, test, trial, c1, c2, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=c2bar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=c2bar, val=c2)
!!
CALL Reallocate(iajb, SIZE(test(1)%N, 1), SIZE(test(1)%T), &
& SIZE(trial(1)%N, 1), SIZE(trial(1)%T))
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_7.inc b/src/submodules/STDiffusionMatrix/src/STDM_7.inc
index 60a248dc0..c2c73c83d 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_7.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_7.inc
@@ -41,7 +41,7 @@ PURE SUBROUTINE STDM_7(ans, test, trial, c1, c2, opt)
!! 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 getInterpolation(obj=trial, ans=c1bar, val=c1)
!!
DO ipt = 1, SIZE(trial)
!!
diff --git a/src/submodules/STDiffusionMatrix/src/STDM_8.inc b/src/submodules/STDiffusionMatrix/src/STDM_8.inc
index 3e4c46518..efcd377ec 100644
--- a/src/submodules/STDiffusionMatrix/src/STDM_8.inc
+++ b/src/submodules/STDiffusionMatrix/src/STDM_8.inc
@@ -40,8 +40,8 @@ PURE SUBROUTINE STDM_8(ans, test, trial, c1, c2, opt)
!! 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)
+ CALL getInterpolation(obj=trial, ans=k1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=k2bar, val=c2)
nsd = trial(1)%refelem%nsd
!!
DO ipt = 1, SIZE(trial)
diff --git a/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90 b/src/submodules/STDiffusionMatrix/src/STDiffusionMatrix_Method@Methods.F90
index 03386ddca..221c93fa0 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)
+ CALL GetInterpolation(obj=trial, ans=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)
+ CALL getInterpolation(obj=trial, ans=kbar, val=k)
!!
- nsd = trial(1)%refelem%nsd
+ nsd = trial(1)%nsd
!!
DO ipt = 1, SIZE(trial)
!!
@@ -177,7 +177,7 @@ PURE SUBROUTINE STDM_12a(ans, test, trial, k, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=k)
+ CALL getInterpolation(obj=trial, ans=vbar, val=k)
!!
CALL Reallocate( &
& IJab, &
@@ -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)
!!
@@ -259,7 +259,7 @@ PURE SUBROUTINE STDM_12b(ans, test, trial, k, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=k)
+ CALL getInterpolation(obj=trial, ans=vbar, val=k)
!!
CALL Reallocate( &
& IJab, &
@@ -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)
+ CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=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)
+ CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=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)
!!
@@ -485,8 +485,8 @@ PURE SUBROUTINE STDM_14a(ans, test, trial, c1, c2, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=cbar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL GetInterpolation(obj=trial, ans=cbar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate( &
& IJab, &
@@ -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)
!!
@@ -571,8 +571,8 @@ PURE SUBROUTINE STDM_14b(ans, test, trial, c1, c2, opt)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=cbar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL GetInterpolation(obj=trial, ans=cbar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate( &
& IJab, &
@@ -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, ans=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,41 @@ 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), ans=p1, c=k, &
+ crank=TypeFEVariableVector)
!!
- CALL GetProjectionOfdNTdXt(obj=trial(ipt), cdNTdXt=p2, val=k)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p2, c=k, &
+ crank=TypeFEVariableVector)
!!
- 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 +783,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, ans=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 +832,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, ans=c1bar, val=c1)
+CALL GetInterpolation(obj=trial, ans=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 +885,42 @@ 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, ans=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), ans=p1, c=c2, &
+ crank=TypeFEVariableVector)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p2, c=c2, &
+ crank=TypeFEVariableVector)
!!
- 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 +933,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, ans=rhobar, val=c1)
+CALL GetInterpolation(obj=trial, ans=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 +987,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 +1002,40 @@ 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), ans=p1, c=c1, &
+ crank=TypeFEVariableVector)
+ CALL GetProjectionOfdNTdXt(obj=trial(ipt), ans=p2, c=c2, &
+ crank=TypeFEVariableVector)
!!
- 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 +1060,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 +1089,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, ans=k1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=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/STForceVector/src/STFV_1.inc b/src/submodules/STForceVector/src/STFV_1.inc
deleted file mode 100644
index 545c440c8..000000000
--- a/src/submodules/STForceVector/src/STFV_1.inc
+++ /dev/null
@@ -1,55 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_1(ans, test, term1)
- !! intent of dummy variable
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD( &
- & a=test(ipt)%N(:, ips), &
- & b=test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval)
- !!
-END SUBROUTINE STFV_1
diff --git a/src/submodules/STForceVector/src/STFV_10.inc b/src/submodules/STForceVector/src/STFV_10.inc
deleted file mode 100644
index 4d1d43572..000000000
--- a/src/submodules/STForceVector/src/STFV_10.inc
+++ /dev/null
@@ -1,63 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_10(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableVector_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, ips, ipt), &
- & test(ipt)%dNTdt(:, :, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_10
diff --git a/src/submodules/STForceVector/src/STFV_11.inc b/src/submodules/STForceVector/src/STFV_11.inc
deleted file mode 100644
index a8dd461fd..000000000
--- a/src/submodules/STForceVector/src/STFV_11.inc
+++ /dev/null
@@ -1,63 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_11(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableMatrix_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(cbar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, :, ips, ipt), &
- & test(ipt)%dNTdt(:, :, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_11
diff --git a/src/submodules/STForceVector/src/STFV_12.inc b/src/submodules/STForceVector/src/STFV_12.inc
deleted file mode 100644
index 30f70caa6..000000000
--- a/src/submodules/STForceVector/src/STFV_12.inc
+++ /dev/null
@@ -1,63 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_12(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_12
diff --git a/src/submodules/STForceVector/src/STFV_13.inc b/src/submodules/STForceVector/src/STFV_13.inc
deleted file mode 100644
index 46c60fca7..000000000
--- a/src/submodules/STForceVector/src/STFV_13.inc
+++ /dev/null
@@ -1,68 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_13(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableVector_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, ips, ipt), &
- & test(ipt)%dNTdt(:, :, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_13
diff --git a/src/submodules/STForceVector/src/STFV_14.inc b/src/submodules/STForceVector/src/STFV_14.inc
deleted file mode 100644
index 2a15e9e59..000000000
--- a/src/submodules/STForceVector/src/STFV_14.inc
+++ /dev/null
@@ -1,68 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_14(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(c2bar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, :, ips, ipt), &
- & test(ipt)%dNTdt(:, :, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_14
diff --git a/src/submodules/STForceVector/src/STFV_15.inc b/src/submodules/STForceVector/src/STFV_15.inc
deleted file mode 100644
index a38e8e233..000000000
--- a/src/submodules/STForceVector/src/STFV_15.inc
+++ /dev/null
@@ -1,53 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_15(ans, test, term1)
- !! intent of dummy variable
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_x, DEL_y, DEL_z
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval)
- !!
-END SUBROUTINE STFV_15
diff --git a/src/submodules/STForceVector/src/STFV_16.inc b/src/submodules/STForceVector/src/STFV_16.inc
deleted file mode 100644
index 1e7d142a4..000000000
--- a/src/submodules/STForceVector/src/STFV_16.inc
+++ /dev/null
@@ -1,58 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_16(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_x, DEL_y, DEL_z
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableScalar_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_16
diff --git a/src/submodules/STForceVector/src/STFV_17.inc b/src/submodules/STForceVector/src/STFV_17.inc
deleted file mode 100644
index 4bca8d65d..000000000
--- a/src/submodules/STForceVector/src/STFV_17.inc
+++ /dev/null
@@ -1,63 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_17(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableVector_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, ips, ipt), &
- & test(ipt)%dNTdXt(:, :, term1, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_17
diff --git a/src/submodules/STForceVector/src/STFV_18.inc b/src/submodules/STForceVector/src/STFV_18.inc
deleted file mode 100644
index 1e6718d30..000000000
--- a/src/submodules/STForceVector/src/STFV_18.inc
+++ /dev/null
@@ -1,63 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_18(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_X, DEL_Y, DEL_Z
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableMatrix_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(cbar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, :, ips, ipt), &
- & test(ipt)%dNTdXt(:, :, term1, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_18
diff --git a/src/submodules/STForceVector/src/STFV_19.inc b/src/submodules/STForceVector/src/STFV_19.inc
deleted file mode 100644
index a25da34d2..000000000
--- a/src/submodules/STForceVector/src/STFV_19.inc
+++ /dev/null
@@ -1,63 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_19(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_X, DEL_Y, DEL_Z
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test(ipt)%dNTdXt(:, :, term1, ips)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_19
diff --git a/src/submodules/STForceVector/src/STFV_2.inc b/src/submodules/STForceVector/src/STFV_2.inc
deleted file mode 100644
index 324e24d1b..000000000
--- a/src/submodules/STForceVector/src/STFV_2.inc
+++ /dev/null
@@ -1,60 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_2(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableScalar_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD( &
- & a=test(ipt)%N(:, ips), &
- & b=test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_2
diff --git a/src/submodules/STForceVector/src/STFV_20.inc b/src/submodules/STForceVector/src/STFV_20.inc
deleted file mode 100644
index 9808f017c..000000000
--- a/src/submodules/STForceVector/src/STFV_20.inc
+++ /dev/null
@@ -1,68 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_20(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_X, DEL_Y, DEL_Z
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableVector_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, ips, ipt), &
- & test(ipt)%dNTdXt(:, :, term1, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_20
diff --git a/src/submodules/STForceVector/src/STFV_21.inc b/src/submodules/STForceVector/src/STFV_21.inc
deleted file mode 100644
index 23b796789..000000000
--- a/src/submodules/STForceVector/src/STFV_21.inc
+++ /dev/null
@@ -1,68 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_21(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(c2bar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, :, ips, ipt), &
- & test(ipt)%dNTdXt(:, :, term1, ips))
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_21
diff --git a/src/submodules/STForceVector/src/STFV_3.inc b/src/submodules/STForceVector/src/STFV_3.inc
deleted file mode 100644
index 76603c036..000000000
--- a/src/submodules/STForceVector/src/STFV_3.inc
+++ /dev/null
@@ -1,64 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_3(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableVector_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_3
diff --git a/src/submodules/STForceVector/src/STFV_4.inc b/src/submodules/STForceVector/src/STFV_4.inc
deleted file mode 100644
index 9035f097f..000000000
--- a/src/submodules/STForceVector/src/STFV_4.inc
+++ /dev/null
@@ -1,64 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_4(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableMatrix_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(cbar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, :, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_4
diff --git a/src/submodules/STForceVector/src/STFV_5.inc b/src/submodules/STForceVector/src/STFV_5.inc
deleted file mode 100644
index 297e0089e..000000000
--- a/src/submodules/STForceVector/src/STFV_5.inc
+++ /dev/null
@@ -1,66 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_5(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & a=test(ipt)%N(:, ips), &
- & b=test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_5
diff --git a/src/submodules/STForceVector/src/STFV_6.inc b/src/submodules/STForceVector/src/STFV_6.inc
deleted file mode 100644
index 9d1f365b2..000000000
--- a/src/submodules/STForceVector/src/STFV_6.inc
+++ /dev/null
@@ -1,69 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_6(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableVector_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_6
diff --git a/src/submodules/STForceVector/src/STFV_7.inc b/src/submodules/STForceVector/src/STFV_7.inc
deleted file mode 100644
index ed62cd905..000000000
--- a/src/submodules/STForceVector/src/STFV_7.inc
+++ /dev/null
@@ -1,69 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_7(ans, test, term1, c1, c1rank, c2, c2rank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :, :, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_NONE
- TYPE(FEVariable_), INTENT(IN) :: c1
- TYPE(FEVariable_), INTENT(IN) :: c2
- TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
- TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: c1bar(:, :)
- REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(c2bar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, :, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, c1bar, c2bar)
- !!
-END SUBROUTINE STFV_7
diff --git a/src/submodules/STForceVector/src/STFV_8.inc b/src/submodules/STForceVector/src/STFV_8.inc
deleted file mode 100644
index dfe340b3f..000000000
--- a/src/submodules/STForceVector/src/STFV_8.inc
+++ /dev/null
@@ -1,53 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_8(ans, test, term1)
- !! intent of dummy variable
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval)
- !!
-END SUBROUTINE STFV_8
diff --git a/src/submodules/STForceVector/src/STFV_9.inc b/src/submodules/STForceVector/src/STFV_9.inc
deleted file mode 100644
index 2ec1de665..000000000
--- a/src/submodules/STForceVector/src/STFV_9.inc
+++ /dev/null
@@ -1,58 +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
-!
-
-!----------------------------------------------------------------------------
-! STForceVector
-!----------------------------------------------------------------------------
-
-PURE SUBROUTINE STFV_9(ans, test, term1, c, crank)
- !! intent of dummy variable
- REAL(DFP), ALLOCATABLE, INTENT(INOUT) :: ans(:, :)
- CLASS(STElemshapeData_), INTENT(IN) :: test(:)
- INTEGER(I4B), INTENT(IN) :: term1
- !! DEL_t
- TYPE(FEVariable_), INTENT(IN) :: c
- TYPE(FEVariableScalar_), INTENT(IN) :: crank
- !!
- !! Define internal variable
- !!
- REAL(DFP), ALLOCATABLE :: realval(:)
- REAL(DFP), ALLOCATABLE :: cbar(:, :)
- INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
- CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
- CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
- DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js*test(ipt)%ws*test(ipt)%thickness*cbar(:,ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * test(ipt)%dNTdt(:, :, ips)
- END DO
- !!
- END DO
- !!
- DEALLOCATE (realval, cbar)
- !!
-END SUBROUTINE STFV_9
diff --git a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90 b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90
index aced7d296..8202dc6bb 100644
--- a/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90
+++ b/src/submodules/STForceVector/src/STForceVector_Method@Methods.F90
@@ -16,850 +16,2074 @@
!
SUBMODULE(STForceVector_Method) Methods
-USE BaseMethod
+USE FEVariable_Method, ONLY: FEVariableGetInterpolation_ => GetInterpolation_
+USE FEVariable_Method, ONLY: FEVariableSize => Size
+USE ReallocateUtility, ONLY: Reallocate
+USE ProductUtility, ONLY: OuterProd_
+USE BaseType, ONLY: TypeDerivativeTerm
+USE BaseType, ONLY: TypeFEVariableSpace, TypeFEVariableVector
+USE BaseType, ONLY: TypeFEVariableMatrix
+USE BaseType, ONLY: math => TypeMathOpt
+USE ElemshapeData_Method, ONLY: GetProjectionOfdNTdXt_
+USE Display_Method, ONLY: display
+
IMPLICIT NONE
CONTAINS
-#include "./STFV_1.inc"
-#include "./STFV_2.inc"
-#include "./STFV_3.inc"
-#include "./STFV_4.inc"
-#include "./STFV_5.inc"
-#include "./STFV_6.inc"
-#include "./STFV_7.inc"
-
-#include "./STFV_8.inc"
-#include "./STFV_9.inc"
-#include "./STFV_10.inc"
-#include "./STFV_11.inc"
-#include "./STFV_12.inc"
-#include "./STFV_13.inc"
-#include "./STFV_14.inc"
-
-#include "./STFV_15.inc"
-#include "./STFV_16.inc"
-#include "./STFV_17.inc"
-#include "./STFV_18.inc"
-#include "./STFV_19.inc"
-#include "./STFV_20.inc"
-#include "./STFV_21.inc"
-
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_1
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * &
- & test(ipt)%Jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD( &
- & a=test(ipt)%N(:, ips), &
- & b=test(ipt)%T)
- END DO
- !!
-END DO
- !!
-DEALLOCATE (realval)
- !!
-END PROCEDURE STForceVector_1
+MODULE PROCEDURE obj_STForceVector1
+INTEGER(I4B) :: nrow, ncol
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(ans=ans, test=test, nrow=nrow, ncol=ncol)
+END PROCEDURE obj_STForceVector1
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_2
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: cbar(:, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * cbar(:, ipt) * test(ipt)%Jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * OUTERPROD( &
- & a=test(ipt)%N(:, ips), &
- & b=test(ipt)%T)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector_1
+REAL(DFP) :: realval
+INTEGER(I4B) :: ips, ipt, nipt, i1, i2
+
+nipt = SIZE(test)
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL OuterProd_( &
+ a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=math%one, &
+ scale=realval, ans=ans, nrow=i1, ncol=i2)
+ END DO
END DO
- !!
-DEALLOCATE (realval, cbar)
- !!
-END PROCEDURE STForceVector_2
+END PROCEDURE obj_STForceVector_1
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_3
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: cbar(:, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector_22
+REAL(DFP) :: realval
+INTEGER(I4B) :: ips, ipt, nipt, nips, i1, i2
+
+nrow = testSpace%nns
+ncol = testTime%nns
+
+nips = testSpace%nips
+nipt = testTime%nips
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, nips
+ realval = testSpace%js(ips) * testSpace%ws(ips) * &
+ testSpace%thickness(ips) * testTime%ws(ipt) * testTime%js(ipt)
+
+ CALL OuterProd_( &
+ a=testSpace%N(1:nrow, ips), b=testTime%N(1:ncol, ipt), &
+ anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2)
+ END DO
END DO
- !!
-DEALLOCATE (realval, cbar)
- !!
-END PROCEDURE STForceVector_3
+END PROCEDURE obj_STForceVector_22
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_4
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: cbar(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL getInterpolation(obj=test, interpol=cbar, val=c)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(cbar, 1), &
- & SIZE(cbar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * test(ipt)%Jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & cbar(:, :, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector2
+INTEGER(I4B) :: nrow, ncol
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(ans=ans, test=test, nrow=nrow, ncol=ncol, c=c, &
+ crank=crank)
+END PROCEDURE obj_STForceVector2
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_2
+REAL(DFP) :: realval, cbar
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2
+
+nipt = SIZE(test)
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar)
+
+ realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=math%one, &
+ scale=realval, ans=ans, nrow=i1, ncol=i2)
+
+ END DO
END DO
- !!
-DEALLOCATE (realval, cbar)
- !!
-END PROCEDURE STForceVector_4
+END PROCEDURE obj_STForceVector_2
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_5
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c1bar(:, :)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * c2bar(:, ipt) * test(ipt)%Jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & a=test(ipt)%N(:, ips), &
- & b=test(ipt)%T)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector_23
+REAL(DFP) :: realval, cbar
+INTEGER(I4B) :: ips, ipt, nipt, nips, i1, i2
+
+nrow = testSpace%nns
+ncol = testTime%nns
+
+nips = testSpace%nips
+nipt = testTime%nips
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=testSpace%N, nns=testSpace%nns, spaceIndx=ips, &
+ timeIndx=ipt, T=testTime%N(:, ipt), nnt=testTime%nns, scale=math%one, &
+ addContribution=math%no, ans=cbar)
+
+ realval = cbar * testSpace%js(ips) * testSpace%ws(ips) * &
+ testSpace%thickness(ips) * testTime%ws(ipt) * testTime%js(ipt)
+
+ CALL OuterProd_( &
+ a=testSpace%N(1:nrow, ips), b=testTime%N(1:ncol, ipt), &
+ anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2)
+ END DO
END DO
- !!
-DEALLOCATE (realval, c1bar, c2bar)
- !!
-END PROCEDURE STForceVector_5
+END PROCEDURE obj_STForceVector_23
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_6
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c1bar(:, :)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%Jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
-END DO
- !!
-DEALLOCATE (realval, c1bar, c2bar)
- !!
-END PROCEDURE STForceVector_6
+MODULE PROCEDURE obj_STForceVector3
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = FEVariableSize(obj=c, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL STForceVector_(test=test, c=c, crank=crank, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3)
+END PROCEDURE obj_STForceVector3
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_7
- !! Define internal variable
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c1bar(:, :)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL getInterpolation(obj=test, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(c2bar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c1bar(:, ipt) * test(ipt)%jt
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, :, ips, ipt), &
- & test(ipt)%N(:, ips), &
- & test(ipt)%T)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector_3
+INTEGER(I4B) :: ips, ipt, nipt, spaceCompo, i1, i2, i3
+REAL(DFP) :: cbar(3), realval
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+DO ipt = 1, nipt
+
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, spaceIndx=ips, &
+ timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, scale=math%one, &
+ addContribution=math%no, ans=cbar, tsize=spaceCompo)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_(a=cbar(1:dim1), b=test(ipt)%N(1:dim2, ips), &
+ c=test(ipt)%T(1:dim3), anscoeff=math%one, scale=realval, &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3)
+
+ END DO
END DO
- !!
-DEALLOCATE (realval, c1bar, c2bar)
- !!
-END PROCEDURE STForceVector_7
+END PROCEDURE obj_STForceVector_3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_8
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_1(ans=ans, test=test, term1=term1)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_8(ans=ans, test=test, term1=term1)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_15(ans=ans, test=test, term1=term1)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_8
+MODULE PROCEDURE obj_STForceVector_24
+INTEGER(I4B) :: ips, ipt, nipt, nips, spaceCompo, i1, i2, i3
+REAL(DFP) :: cbar(3), realval
+
+dim1 = FEVariableSize(obj=c, dim=1)
+
+dim2 = testSpace%nns
+nips = testSpace%nips
+
+dim3 = testTime%nns
+nipt = testTime%nips
+
+ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+DO ipt = 1, nipt
+
+ DO ips = 1, nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=testSpace%N, nns=testSpace%nns, spaceIndx=ips, &
+ timeIndx=ipt, T=testTime%N(:, ipt), nnt=testTime%nns, scale=math%one, &
+ addContribution=math%no, ans=cbar, tsize=spaceCompo)
+
+ realval = testSpace%js(ips) * testSpace%ws(ips) * &
+ testSpace%thickness(ips) * testTime%js(ipt) * testTime%ws(ipt)
+
+ CALL OuterProd_(a=cbar(1:dim1), b=testSpace%N(1:dim2, ips), &
+ c=testtime%N(1:dim3, ipt), &
+ anscoeff=math%one, scale=realval, &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3)
+
+ END DO
+END DO
+
+END PROCEDURE obj_STForceVector_24
!----------------------------------------------------------------------------
-!
+! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_9
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_2(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_9(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_16(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_9
+MODULE PROCEDURE obj_STForceVector4
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+
+dim1 = FEVariableSize(obj=c, dim=1)
+dim2 = FEVariableSize(obj=c, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+
+CALL STForceVector_(test=test, c=c, crank=crank, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3, dim4=dim4)
+END PROCEDURE obj_STForceVector4
!----------------------------------------------------------------------------
-!
+! STForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_10
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_3(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_10(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_17(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_10
+MODULE PROCEDURE obj_STForceVector_4
+INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+REAL(DFP) :: cbar(3, 3), realval
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c, dim=1)
+dim2 = FEVariableSize(obj=c, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+DO ipt = 1, nipt
+
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, spaceIndx=ips, &
+ timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, scale=math%one, &
+ addContribution=math%no, ans=cbar, nrow=i1, ncol=i2)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_(a=cbar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), &
+ c=test(ipt)%T(1:dim4), anscoeff=math%one, scale=realval, &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4)
+
+ END DO
+END DO
+END PROCEDURE obj_STForceVector_4
!----------------------------------------------------------------------------
-!
+! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_11
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_4(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_11(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_18(ans=ans, test=test, term1=term1, c=c, crank=crank)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_11
+MODULE PROCEDURE obj_STForceVector5
+INTEGER(I4B) :: nrow, ncol
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(test=test, ans=ans, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, nrow=nrow, ncol=ncol)
+END PROCEDURE obj_STForceVector5
!----------------------------------------------------------------------------
-!
+! STForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_12
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_5(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_12(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_19(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_12
+MODULE PROCEDURE obj_STForceVector_5
+REAL(DFP) :: realval, c1bar, c2bar
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2
+
+nipt = SIZE(test)
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), anscoeff=math%one, &
+ scale=realval, ans=ans, nrow=i1, ncol=i2)
+
+ END DO
+END DO
+END PROCEDURE obj_STForceVector_5
!----------------------------------------------------------------------------
-!
+! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_13
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_6(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_13(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_20(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_13
+MODULE PROCEDURE obj_STForceVector6
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL STForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE obj_STForceVector6
!----------------------------------------------------------------------------
-!
+! STForceVector_
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_14
- !!
-SELECT CASE (term1)
- !!
- !!
- !!
-CASE (DEL_NONE)
- !!
- CALL STFV_7(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_t)
- !!
- CALL STFV_14(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_X, DEL_Y, DEL_Z)
- !!
- CALL STFV_21(ans=ans, test=test, term1=term1, c1=c1, c1rank=c1rank, &
- & c2=c2, c2rank=c2rank)
- !!
- !!
- !!
-CASE (DEL_X_ALL)
- !!
- !! TODO
- !!
-END SELECT
- !!
-END PROCEDURE STForceVector_14
+MODULE PROCEDURE obj_STForceVector_6
+REAL(DFP) :: realval, c1bar, c2bar(3)
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1), b=test(ipt)%N(1:dim2, ips), &
+ c=test(ipt)%T(1:dim3), anscoeff=math%one, &
+ scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3)
+
+ END DO
+END DO
+END PROCEDURE obj_STForceVector_6
!----------------------------------------------------------------------------
-! STForceVector
+! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_15
- !!
- !! Define internal variable
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * p1(:, :, ips, ipt)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector7
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = FEVariableSize(obj=c2, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL STForceVector_(test=test, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4)
+END PROCEDURE obj_STForceVector7
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_7
+INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+REAL(DFP) :: realval, c1bar, c2bar(3, 3)
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = FEVariableSize(obj=c2, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+DO ipt = 1, nipt
+
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), &
+ c=test(ipt)%T(1:dim4), anscoeff=math%one, &
+ scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4)
+
+ END DO
END DO
- !!
-DEALLOCATE (realval, p1)
- !!
-END PROCEDURE STForceVector_15
+END PROCEDURE obj_STForceVector_7
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_16
- !!
- !! Define internal variable
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * c2bar(:, ipt)
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * p1(:, :, ips, ipt)
- END DO
- !!
-END DO
- !!
-DEALLOCATE (realval, p1, c2bar)
- !!
+MODULE PROCEDURE obj_STForceVector15
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+INTEGER(I4B) :: nrow, ncol
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(temp, nrow, ncol)
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(test=test, projection=projection, c=c, crank=crank, &
+ ans=ans, nrow=nrow, ncol=ncol, temp=temp)
+
+DEALLOCATE (temp)
+END PROCEDURE obj_STForceVector15
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_15
+REAL(DFP) :: realval
+INTEGER(I4B) :: ips, ipt, nipt, i1, i2
+
+nipt = SIZE(test)
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
-END PROCEDURE STForceVector_16
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, ans=temp, c=c, crank=crank, nrow=i1, ncol=i2, ips=ips, &
+ ipt=ipt)
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + realval * temp(1:i1, 1:i2)
+ END DO
+
+END DO
+END PROCEDURE obj_STForceVector_15
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_17
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :, :)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD( &
- & c2bar(:, ips, ipt), &
- & p1(:, :, ips, ipt))
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector16
+INTEGER(I4B) :: nrow, ncol
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(temp, nrow, ncol)
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_( &
+ test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, nrow=nrow, ncol=ncol, temp=temp)
+END PROCEDURE obj_STForceVector16
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_16
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2
+REAL(DFP) :: realval
+
+nipt = SIZE(test)
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=realval)
+
+ realval = realval * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, &
+ ans=temp, nrow=i1, ncol=i2)
+
+ ans(1:i1, 1:i2) = ans(1:i1, 1:i2) + realval * temp(1:i1, 1:i2)
+ END DO
END DO
- !!
-DEALLOCATE (realval, p1, c2bar)
- !!
-END PROCEDURE STForceVector_17
+END PROCEDURE obj_STForceVector_16
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_18
- !!
- !! Define internal variable
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :, :, :)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(c2bar, 1), &
- & SIZE(c2bar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) &
- & * OUTERPROD(c2bar(:, :, ips, ipt), p1(:, :, ips, ipt))
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector17
+INTEGER(I4B) :: dim1, dim2, dim3
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+CALL Reallocate(temp, dim2, dim3)
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL STForceVector_( &
+ test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, temp=temp)
+DEALLOCATE (temp)
+END PROCEDURE obj_STForceVector17
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_17
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3
+REAL(DFP) :: realval, c2bar(3)
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1)
+
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, &
+ ncol=i2)
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1), b=temp(1:dim2, 1:dim3), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval)
+
+ END DO
END DO
- !!
-DEALLOCATE (realval, p1, c2bar)
- !!
-END PROCEDURE STForceVector_18
+END PROCEDURE obj_STForceVector_17
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_19
- !!
- !! Define internal variable
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :)
-REAL(DFP), ALLOCATABLE :: c3bar(:, :)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
-CALL getInterpolation(obj=test, interpol=c3bar, val=c3)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js &
- & * test(ipt)%ws &
- & * test(ipt)%thickness &
- & * c2bar(:, ipt) &
- & * c3bar(:, ipt)
- !!
- !!
- DO ips = 1, SIZE(realval)
- ans = ans + realval(ips) * p1(:, :, ips, ipt)
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector18
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = FEVariableSize(obj=c2, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+CALL Reallocate(temp, dim3, dim4)
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL STForceVector_( &
+ test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4, &
+ temp=temp)
+
+DEALLOCATE (temp)
+END PROCEDURE obj_STForceVector18
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_18
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3, i4
+REAL(DFP) :: realval, c2bar(3, 3)
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = FEVariableSize(obj=c2, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2)
+
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, &
+ ncol=i2)
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1, 1:dim2), b=temp(1:dim3, 1:dim4), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, &
+ anscoeff=math%one, scale=realval)
+
+ END DO
END DO
- !!
-DEALLOCATE (realval, p1, c2bar, c3bar)
- !!
-END PROCEDURE STForceVector_19
+END PROCEDURE obj_STForceVector_18
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_20
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :)
-REAL(DFP), ALLOCATABLE :: c3bar(:, :, :)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
-CALL getInterpolation(obj=test, interpol=c3bar, val=c3)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(c3bar, 1), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness &
- & * c2bar(:, ipt)
- !!
- DO ips = 1, SIZE(realval)
- ans = ans &
- & + realval(ips) &
- & * OUTERPROD(c3bar(:, ips, ipt), p1(:, :, ips, ipt))
- END DO
- !!
+MODULE PROCEDURE obj_STForceVector19
+INTEGER(I4B) :: nrow, ncol
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(temp, nrow, ncol)
+CALL Reallocate(ans, nrow, ncol)
+
+CALL STForceVector_( &
+ test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, c3=c3, c3rank=c3rank, ans=ans, nrow=nrow, ncol=ncol, &
+ temp=temp)
+
+DEALLOCATE (temp)
+END PROCEDURE obj_STForceVector19
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_19
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2
+REAL(DFP) :: realval, c2bar, c3bar
+
+nipt = SIZE(test)
+nrow = test(1)%nns
+ncol = test(1)%nnt
+
+ans(1:nrow, 1:ncol) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c3, rank=c3rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c3bar)
+
+ realval = c2bar * c3bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, &
+ ans=temp, nrow=i1, ncol=i2)
+
+ ans(1:i1, 1:i2) = ans(1:i1, 1:i2) + realval * temp(1:i1, 1:i2)
+ END DO
END DO
- !!
-DEALLOCATE (realval, p1, c2bar, c3bar)
- !!
-END PROCEDURE STForceVector_20
+END PROCEDURE obj_STForceVector_19
!----------------------------------------------------------------------------
! STForceVector
!----------------------------------------------------------------------------
-MODULE PROCEDURE STForceVector_21
- !!
- !! Define internal variable
- !!
-REAL(DFP), ALLOCATABLE :: realval(:)
-REAL(DFP), ALLOCATABLE :: c2bar(:, :)
-REAL(DFP), ALLOCATABLE :: c3bar(:, :, :, :)
-REAL(DFP), ALLOCATABLE :: p1(:, :, :, :)
-INTEGER(I4B) :: ips, ipt
- !!
- !! main
- !!
-CALL GetProjectionOfdNTdXt(obj=test, cdNTdXt=p1, val=c1)
-CALL getInterpolation(obj=test, interpol=c2bar, val=c2)
-CALL getInterpolation(obj=test, interpol=c3bar, val=c3)
- !!
-CALL reallocate( &
- & ans, &
- & SIZE(c3bar, 1), &
- & SIZE(c3bar, 2), &
- & SIZE(test(1)%N, 1), &
- & SIZE(test(1)%T))
- !!
-DO ipt = 1, SIZE(test)
- !!
- realval = test(ipt)%js * test(ipt)%ws * test(ipt)%thickness * &
- & c2bar(:, ipt)
- !!
- DO ips = 1, SIZE(realval)
- !!
- ans = ans + realval(ips) * OUTERPROD( &
- & c3bar(:, :, ips, ipt), &
- & p1(:, :, ips, ipt))
- !!
+MODULE PROCEDURE obj_STForceVector20
+INTEGER(I4B) :: dim1, dim2, dim3
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+dim1 = FEVariableSize(obj=c3, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+
+CALL Reallocate(temp, dim2, dim3)
+CALL Reallocate(ans, dim1, dim2, dim3)
+
+CALL STForceVector_( &
+ test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, c3=c3, c3rank=c3rank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, temp=temp)
+
+DEALLOCATE (temp)
+END PROCEDURE obj_STForceVector20
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_20
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3
+REAL(DFP) :: realval, c2bar, c3bar(3)
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c3, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c3, rank=c3rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c3bar, tsize=i1)
+
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, &
+ ncol=i2)
+
+ realval = c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL OuterProd_( &
+ a=c3bar(1:dim1), b=temp(1:dim2, 1:dim3), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval)
+
END DO
END DO
- !!
-DEALLOCATE (realval, p1, c2bar, c3bar)
- !!
-END PROCEDURE STForceVector_21
+END PROCEDURE obj_STForceVector_20
!----------------------------------------------------------------------------
-!
+! STForceVector
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector21
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+REAL(DFP), ALLOCATABLE :: temp(:, :)
+
+dim1 = FEVariableSize(obj=c3, dim=1)
+dim2 = FEVariableSize(obj=c3, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+CALL Reallocate(temp, dim3, dim4)
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL STForceVector_( &
+ test=test, projection=projection, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, c3=c3, c3rank=c3rank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4, temp=temp)
+
+DEALLOCATE (temp)
+END PROCEDURE obj_STForceVector21
+
+!----------------------------------------------------------------------------
+! STForceVector21_
!----------------------------------------------------------------------------
+MODULE PROCEDURE obj_STForceVector_21
+INTEGER(I4B) :: nipt, ipt, ips, i1, i2, i3, i4
+REAL(DFP) :: realval, c3bar(3, 3), c2bar
+
+nipt = SIZE(test)
+dim1 = FEVariableSize(obj=c3, dim=1)
+dim2 = FEVariableSize(obj=c3, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL GetProjectionOfdNTdXt_( &
+ obj=test, c=c1, crank=c1rank, ips=ips, ipt=ipt, ans=temp, nrow=i1, &
+ ncol=i2)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c3, rank=c3rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c3bar, nrow=i1, ncol=i2)
+
+ realval = c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%wt * test(ipt)%jt
+
+ CALL OuterProd_( &
+ a=c3bar(1:dim1, 1:dim2), b=temp(1:dim3, 1:dim4), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, &
+ anscoeff=math%one, scale=realval)
+
+ END DO
+END DO
+END PROCEDURE obj_STForceVector_21
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector8
+INTEGER(I4B) :: nrow, ncol
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(test=test, term1=term1, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE obj_STForceVector8
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_8
+SELECT CASE (term1)
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_8a(test=test, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_8b(test=test, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_8c(test=test, ans=ans, term1=term1, nrow=nrow, ncol=ncol)
+
+! CASE (TypeDerivativeTerm%xAll)
+
+END SELECT
+END PROCEDURE obj_STForceVector_8
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+! term1 is NONE
+PURE SUBROUTINE STFV_8a(test, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Internal variables
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2
+ REAL(DFP) :: realval
+
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_(a=test(ipt)%N(1:nrow, ips), &
+ b=test(ipt)%T(1:ncol), &
+ anscoeff=math%one, scale=realval, &
+ ans=ans, nrow=i1, ncol=i2)
+ END DO
+ END DO
+END SUBROUTINE STFV_8a
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_8b(test, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval
+ INTEGER(I4B) :: ips, ipt, nipt
+
+ !! main
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * test(ipt)%dNTdt(1:nrow, 1:ncol, ips)
+ END DO
+ END DO
+END SUBROUTINE STFV_8b
+
+!----------------------------------------------------------------------------
+! STFV_15
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE STFV_8c(test, ans, term1, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ !! DEL_x, DEL_y, DEL_z
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval
+ INTEGER(I4B) :: ips, ipt, nipt
+
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) &
+ + realval * test(ipt)%dNTdXt(1:nrow, 1:ncol, term1, ips)
+ END DO
+ END DO
+END SUBROUTINE STFV_8c
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector9
+INTEGER(I4B) :: nrow, ncol
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(test=test, term1=term1, c=c, crank=crank, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE obj_STForceVector9
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_9
+SELECT CASE (term1)
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_9a(test=test, c=c, crank=crank, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_9b(test=test, c=c, crank=crank, ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_9c(test=test, term1=term1, c=c, crank=crank, ans=ans, &
+ nrow=nrow, ncol=ncol)
+! CASE (TypeDerivativeTerm%xAll)
+END SELECT
+END PROCEDURE obj_STForceVector_9
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE STFV_9a(test, c, crank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2
+ REAL(DFP) :: realval, cbar
+
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * cbar * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), &
+ anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2)
+ END DO
+ END DO
+END SUBROUTINE STFV_9a
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+! term is t
+PURE SUBROUTINE STFV_9b(test, c, crank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar
+ INTEGER(I4B) :: ips, ipt, nipt
+
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar)
+
+ realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * test(ipt)%dNTdt(1:nrow, 1:ncol, ips)
+ END DO
+ END DO
+END SUBROUTINE STFV_9b
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term is x, y, z
+PURE SUBROUTINE STFV_9c(test, term1, c, crank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ ! DEL_x, DEL_y, DEL_z
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableScalar_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar
+ INTEGER(I4B) :: ips, ipt, nipt
+
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar)
+
+ realval = cbar * test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + realval * &
+ test(ipt)%dNTdXt(1:nrow, 1:ncol, term1, ips)
+ END DO
+ END DO
+END SUBROUTINE STFV_9c
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector10
+INTEGER(I4B) :: dim1, dim2, dim3
+dim1 = FEVariableSize(obj=c, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL STForceVector_(test=test, term1=term1, c=c, crank=crank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE obj_STForceVector10
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_10
+SELECT CASE (term1)
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_10a(test=test, c=c, crank=crank, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3)
+
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_10b(test=test, c=c, crank=crank, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_10c(test=test, c=c, crank=crank, ans=ans, dim1=dim1, &
+ dim2=dim2, dim3=dim3, term1=term1)
+
+! CASE (TypeDerivativeTerm%xAll)
+
+END SELECT
+END PROCEDURE obj_STForceVector_10
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE STFV_10a(test, c, crank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar(3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c, dim=1)
+ dim2 = test(1)%nns
+ dim3 = test(1)%nnt
+
+ ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar, tsize=i1)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=cbar(1:dim1), b=test(ipt)%N(1:dim2, ips), &
+ c=test(ipt)%T(1:dim3), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, &
+ anscoeff=math%one, scale=realval)
+ END DO
+ END DO
+END SUBROUTINE STFV_10a
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_10b(test, c, crank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar(3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c, dim=1)
+ dim2 = test(1)%nns
+ dim3 = test(1)%nnt
+
+ ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar, tsize=i1)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=cbar(1:dim1), b=test(ipt)%dNTdt(1:dim2, 1:dim3, ips), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_10b
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+! term1 is x, y, z
+PURE SUBROUTINE STFV_10c(test, term1, c, crank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableVector_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar(3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c, dim=1)
+ dim2 = test(1)%nns
+ dim3 = test(1)%nnt
+
+ ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar, tsize=i1)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=cbar(1:dim1), b=test(ipt)%dNTdXt(1:dim2, 1:dim3, term1, ips), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, anscoeff=math%one, scale=realval)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_10c
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector11
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+
+dim1 = FEVariableSize(obj=c, dim=1)
+dim2 = FEVariableSize(obj=c, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL STForceVector_( &
+ test=test, term1=term1, c=c, crank=crank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4)
+END PROCEDURE obj_STForceVector11
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_11
+SELECT CASE (term1)
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_11a(test=test, c=c, crank=crank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4)
+
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_11b(test=test, c=c, crank=crank, ans=ans, dim1=dim1, dim2=dim2, &
+ dim3=dim3, dim4=dim4)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_11c(test=test, term1=term1, c=c, crank=crank, ans=ans, &
+ dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+
+END SELECT
+END PROCEDURE obj_STForceVector_11
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+! term1 is NONE
+PURE SUBROUTINE STFV_11a(test, c, crank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar(3, 3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+
+ dim1 = FEVariableSize(obj=c, dim=1)
+ dim2 = FEVariableSize(obj=c, dim=2)
+ dim3 = test(1)%nns
+ dim4 = test(1)%nnt
+ nipt = SIZE(test)
+
+ ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar, nrow=i1, ncol=i2)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=cbar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), &
+ c=test(ipt)%T(1:dim4), ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, &
+ anscoeff=math%one, scale=realval)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_11a
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_11b(test, c, crank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar(3, 3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+
+ dim1 = FEVariableSize(obj=c, dim=1)
+ dim2 = FEVariableSize(obj=c, dim=2)
+ dim3 = test(1)%nns
+ dim4 = test(1)%nnt
+ nipt = SIZE(test)
+
+ ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar, nrow=i1, ncol=i2)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=cbar(1:dim1, 1:dim2), b=test(ipt)%dNTdt(1:dim3, 1:dim4, ips), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, &
+ anscoeff=math%one, scale=realval)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_11b
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_11c(test, term1, c, crank, ans, dim1, dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c
+ TYPE(FEVariableMatrix_), INTENT(IN) :: crank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ ! Define internal variable
+ REAL(DFP) :: realval, cbar(3, 3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+
+ dim1 = FEVariableSize(obj=c, dim=1)
+ dim2 = FEVariableSize(obj=c, dim=2)
+ dim3 = test(1)%nns
+ dim4 = test(1)%nnt
+ nipt = SIZE(test)
+
+ ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c, rank=crank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=cbar, nrow=i1, ncol=i2)
+
+ realval = test(ipt)%js(ips) * test(ipt)%ws(ips) * &
+ test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=cbar(1:dim1, 1:dim2), &
+ b=test(ipt)%dNTdXt(1:dim3, 1:dim4, term1, ips), &
+ ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4, &
+ anscoeff=math%one, scale=realval)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_11c
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector12
+INTEGER(I4B) :: nrow, ncol
+nrow = test(1)%nns
+ncol = test(1)%nnt
+CALL Reallocate(ans, nrow, ncol)
+CALL STForceVector_(test=test, term1=term1, c1=c1, c1rank=c1rank, &
+ c2=c2, c2rank=c2rank, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE obj_STForceVector12
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_12
+SELECT CASE (term1)
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_12a(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, nrow=nrow, ncol=ncol)
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_12b(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_12c(test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, nrow=nrow, ncol=ncol)
+
+! CASE (TypeDerivativeTerm%xAll)
+
+END SELECT
+END PROCEDURE obj_STForceVector_12
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+! term1 is none
+PURE SUBROUTINE STFV_12a(test, c1, c1rank, c2, c2rank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval, c1bar, c2bar
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2
+
+ ! main
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=test(ipt)%N(1:nrow, ips), b=test(ipt)%T(1:ncol), &
+ anscoeff=math%one, scale=realval, ans=ans, nrow=i1, ncol=i2)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_12a
+
+!----------------------------------------------------------------------------
+! STForceVector
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_12b(test, c1, c1rank, c2, c2rank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval, c1bar, c2bar
+ INTEGER(I4B) :: ips, ipt, nipt
+
+ ! main
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * test(ipt)%dNTdt(1:nrow, 1:ncol, ips)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_12b
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term1 is x, y, z
+PURE SUBROUTINE STFV_12c(test, term1, c1, c1rank, c2, c2rank, ans, nrow, ncol)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableScalar_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ INTEGER(I4B), INTENT(OUT) :: nrow, ncol
+
+ ! Define internal variable
+ REAL(DFP) :: realval, c1bar, c2bar
+ INTEGER(I4B) :: ips, ipt, nipt
+
+ ! main
+ nipt = SIZE(test)
+ nrow = test(1)%nns
+ ncol = test(1)%nnt
+
+ ans(1:nrow, 1:ncol) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar)
+
+ realval = c1bar * c2bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ ans(1:nrow, 1:ncol) = ans(1:nrow, 1:ncol) + &
+ realval * test(ipt)%dNTdXt(1:nrow, 1:ncol, term1, ips)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_12c
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector13
+INTEGER(I4B) :: dim1, dim2, dim3
+
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = test(1)%nns
+dim3 = test(1)%nnt
+CALL Reallocate(ans, dim1, dim2, dim3)
+CALL STForceVector_( &
+ test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE obj_STForceVector13
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_13
+SELECT CASE (term1)
+
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_13a(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_13b(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_13c(test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+
+! CASE (TypeDerivativeTerm%xAll)
+END SELECT
+END PROCEDURE obj_STForceVector_13
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+PURE SUBROUTINE STFV_13a(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ ! Internal variables
+ REAL(DFP) :: realval, c2bar(3), c1bar
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c2, dim=1)
+ dim2 = test(1)%nns
+ dim3 = test(1)%nnt
+
+ ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1), b=test(ipt)%N(1:dim2, ips), c=test(ipt)%T(1:dim3), &
+ anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_13a
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_13b(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ ! Internal variables
+ REAL(DFP) :: realval, c2bar(3), c1bar
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c2, dim=1)
+ dim2 = test(1)%nns
+ dim3 = test(1)%nnt
+
+ ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1), b=test(ipt)%dNTdt(1:dim2, 1:dim3, ips), &
+ anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_13b
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term1 is x, y, z
+PURE SUBROUTINE STFV_13c(test, term1, c1, c1rank, c2, c2rank, ans, dim1, &
+ dim2, dim3)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableVector_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3
+
+ ! Internal variables
+ REAL(DFP) :: realval, c2bar(3), c1bar
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c2, dim=1)
+ dim2 = test(1)%nns
+ dim3 = test(1)%nnt
+
+ ans(1:dim1, 1:dim2, 1:dim3) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, tsize=i1)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1), b=test(ipt)%dNTdXt(1:dim2, 1:dim3, term1, ips), &
+ anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_13c
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector14
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+dim1 = FEVariableSize(obj=c2, dim=1)
+dim2 = FEVariableSize(obj=c2, dim=2)
+dim3 = test(1)%nns
+dim4 = test(1)%nnt
+
+CALL Reallocate(ans, dim1, dim2, dim3, dim4)
+CALL STForceVector_( &
+ test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+END PROCEDURE obj_STForceVector14
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_STForceVector_14
+SELECT CASE (term1)
+
+CASE (TypeDerivativeTerm%NONE)
+ CALL STFV_14a(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+
+CASE (TypeDerivativeTerm%t)
+ CALL STFV_14b(test=test, c1=c1, c1rank=c1rank, c2=c2, c2rank=c2rank, &
+ ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+
+CASE (TypeDerivativeTerm%x, TypeDerivativeTerm%y, TypeDerivativeTerm%z)
+ CALL STFV_14c(test=test, term1=term1, c1=c1, c1rank=c1rank, c2=c2, &
+ c2rank=c2rank, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
+
+CASE (TypeDerivativeTerm%xAll)
+END SELECT
+END PROCEDURE obj_STForceVector_14
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term1 is none
+PURE SUBROUTINE STFV_14a(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, &
+ dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ !! Internal variables
+ REAL(DFP) :: realval, c1bar, c2bar(3, 3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c2, dim=1)
+ dim2 = FEVariableSize(obj=c2, dim=2)
+ dim3 = test(1)%nns
+ dim4 = test(1)%nnt
+ ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1, 1:dim2), b=test(ipt)%N(1:dim3, ips), &
+ c=test(ipt)%T(1:dim4), anscoeff=math%one, scale=realval, ans=ans, &
+ dim1=i1, dim2=i2, dim3=i3, dim4=i4)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_14a
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term1 is t
+PURE SUBROUTINE STFV_14b(test, c1, c1rank, c2, c2rank, ans, dim1, dim2, &
+ dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ !! Internal variables
+ REAL(DFP) :: realval, c1bar, c2bar(3, 3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c2, dim=1)
+ dim2 = FEVariableSize(obj=c2, dim=2)
+ dim3 = test(1)%nns
+ dim4 = test(1)%nnt
+ ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1, 1:dim2), b=test(ipt)%dNTdt(1:dim3, 1:dim4, ips), &
+ anscoeff=math%one, scale=realval, ans=ans, dim1=i1, dim2=i2, &
+ dim3=i3, dim4=i4)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_14b
+
+!----------------------------------------------------------------------------
+! STForceVector_
+!----------------------------------------------------------------------------
+
+! term1 is x, y, z
+PURE SUBROUTINE STFV_14c(test, term1, c1, c1rank, c2, c2rank, ans, dim1, &
+ dim2, dim3, dim4)
+ CLASS(STElemshapeData_), INTENT(IN) :: test(:)
+ INTEGER(I4B), INTENT(IN) :: term1
+ TYPE(FEVariable_), INTENT(IN) :: c1
+ TYPE(FEVariable_), INTENT(IN) :: c2
+ TYPE(FEVariableScalar_), INTENT(IN) :: c1rank
+ TYPE(FEVariableMatrix_), INTENT(IN) :: c2rank
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :, :)
+ INTEGER(I4B), INTENT(OUT) :: dim1, dim2, dim3, dim4
+
+ !! Internal variables
+ REAL(DFP) :: realval, c1bar, c2bar(3, 3)
+ INTEGER(I4B) :: ips, ipt, nipt, i1, i2, i3, i4
+
+ nipt = SIZE(test)
+ dim1 = FEVariableSize(obj=c2, dim=1)
+ dim2 = FEVariableSize(obj=c2, dim=2)
+ dim3 = test(1)%nns
+ dim4 = test(1)%nnt
+ ans(1:dim1, 1:dim2, 1:dim3, 1:dim4) = math%zero
+
+ DO ipt = 1, nipt
+ DO ips = 1, test(ipt)%nips
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c1, rank=c1rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c1bar)
+
+ CALL FEVariableGetInterpolation_( &
+ obj=c2, rank=c2rank, N=test(ipt)%N, nns=test(ipt)%nns, &
+ spaceIndx=ips, timeIndx=ipt, T=test(ipt)%T, nnt=test(ipt)%nnt, &
+ scale=math%one, addContribution=math%no, ans=c2bar, nrow=i1, ncol=i2)
+
+ realval = c1bar * test(ipt)%js(ips) * test(ipt)%ws(ips) &
+ * test(ipt)%thickness(ips) * test(ipt)%jt * test(ipt)%wt
+
+ CALL OuterProd_( &
+ a=c2bar(1:dim1, 1:dim2), &
+ b=test(ipt)%dNTdXt(1:dim3, 1:dim4, term1, ips), anscoeff=math%one, &
+ scale=realval, ans=ans, dim1=i1, dim2=i2, dim3=i3, dim4=i4)
+
+ END DO
+ END DO
+END SUBROUTINE STFV_14c
+
+!----------------------------------------------------------------------------
+! Include error
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
END SUBMODULE Methods
diff --git a/src/submodules/STMassMatrix/src/STMM_10.inc b/src/submodules/STMassMatrix/src/STMM_10.inc
index 5fcce6471..8d8be54b6 100644
--- a/src/submodules/STMassMatrix/src/STMM_10.inc
+++ b/src/submodules/STMassMatrix/src/STMM_10.inc
@@ -40,7 +40,7 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_11.inc b/src/submodules/STMassMatrix/src/STMM_11.inc
index dd37d0b9d..af80820ac 100644
--- a/src/submodules/STMassMatrix/src/STMM_11.inc
+++ b/src/submodules/STMassMatrix/src/STMM_11.inc
@@ -43,7 +43,7 @@
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_12.inc b/src/submodules/STMassMatrix/src/STMM_12.inc
index fae4e434d..50d93c589 100644
--- a/src/submodules/STMassMatrix/src/STMM_12.inc
+++ b/src/submodules/STMassMatrix/src/STMM_12.inc
@@ -38,7 +38,7 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
diff --git a/src/submodules/STMassMatrix/src/STMM_13.inc b/src/submodules/STMassMatrix/src/STMM_13.inc
index f5b9512b2..23c0dc44b 100644
--- a/src/submodules/STMassMatrix/src/STMM_13.inc
+++ b/src/submodules/STMassMatrix/src/STMM_13.inc
@@ -38,7 +38,7 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_14.inc b/src/submodules/STMassMatrix/src/STMM_14.inc
index 93e435df6..1bef25201 100644
--- a/src/submodules/STMassMatrix/src/STMM_14.inc
+++ b/src/submodules/STMassMatrix/src/STMM_14.inc
@@ -39,7 +39,7 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_15.inc b/src/submodules/STMassMatrix/src/STMM_15.inc
index a3cca6c48..3d9137198 100644
--- a/src/submodules/STMassMatrix/src/STMM_15.inc
+++ b/src/submodules/STMassMatrix/src/STMM_15.inc
@@ -37,7 +37,7 @@ PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_16.inc b/src/submodules/STMassMatrix/src/STMM_16.inc
index f2f7934f4..26f80009e 100644
--- a/src/submodules/STMassMatrix/src/STMM_16.inc
+++ b/src/submodules/STMassMatrix/src/STMM_16.inc
@@ -37,7 +37,7 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
diff --git a/src/submodules/STMassMatrix/src/STMM_17_20.inc b/src/submodules/STMassMatrix/src/STMM_17_20.inc
index 79fa78f10..15cdbd362 100644
--- a/src/submodules/STMassMatrix/src/STMM_17_20.inc
+++ b/src/submodules/STMassMatrix/src/STMM_17_20.inc
@@ -43,8 +43,8 @@ CALL Reallocate(IaJb, &
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
-CALL GetInterpolation(obj=trial, interpol=m2, val=c1)
-CALL GetInterpolation(obj=trial, interpol=m2b, val=c2)
+CALL GetInterpolation(obj=trial, ans=m2, val=c1)
+CALL GetInterpolation(obj=trial, ans=m2b, val=c2)
!!
DO ipt = 1, SIZE(trial)
!!
diff --git a/src/submodules/STMassMatrix/src/STMM_21.inc b/src/submodules/STMassMatrix/src/STMM_21.inc
index 7d80f5c6f..06ba0feab 100644
--- a/src/submodules/STMassMatrix/src/STMM_21.inc
+++ b/src/submodules/STMassMatrix/src/STMM_21.inc
@@ -40,8 +40,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_22.inc b/src/submodules/STMassMatrix/src/STMM_22.inc
index 8b90d56fd..2afef3b37 100644
--- a/src/submodules/STMassMatrix/src/STMM_22.inc
+++ b/src/submodules/STMassMatrix/src/STMM_22.inc
@@ -42,8 +42,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_23.inc b/src/submodules/STMassMatrix/src/STMM_23.inc
index 392086dc1..4d1254421 100644
--- a/src/submodules/STMassMatrix/src/STMM_23.inc
+++ b/src/submodules/STMassMatrix/src/STMM_23.inc
@@ -45,8 +45,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -77,4 +77,4 @@ END DO
!!
CALL Convert(from=m6, to=ans)
!!
-DEALLOCATE (m6, ij, c1bar, vbar, realval)
\ No newline at end of file
+DEALLOCATE (m6, ij, c1bar, vbar, realval)
diff --git a/src/submodules/STMassMatrix/src/STMM_24.inc b/src/submodules/STMassMatrix/src/STMM_24.inc
index 864486652..fb27dcf23 100644
--- a/src/submodules/STMassMatrix/src/STMM_24.inc
+++ b/src/submodules/STMassMatrix/src/STMM_24.inc
@@ -40,8 +40,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL GetInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_25.inc b/src/submodules/STMassMatrix/src/STMM_25.inc
index 5c3c7a257..d5e65e3aa 100644
--- a/src/submodules/STMassMatrix/src/STMM_25.inc
+++ b/src/submodules/STMassMatrix/src/STMM_25.inc
@@ -41,8 +41,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_26.inc b/src/submodules/STMassMatrix/src/STMM_26.inc
index cfff28b2b..a7e46f2d2 100644
--- a/src/submodules/STMassMatrix/src/STMM_26.inc
+++ b/src/submodules/STMassMatrix/src/STMM_26.inc
@@ -43,8 +43,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_27.inc b/src/submodules/STMassMatrix/src/STMM_27.inc
index 5e54e6983..9be467218 100644
--- a/src/submodules/STMassMatrix/src/STMM_27.inc
+++ b/src/submodules/STMassMatrix/src/STMM_27.inc
@@ -40,8 +40,8 @@ PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_28.inc b/src/submodules/STMassMatrix/src/STMM_28.inc
index 6bd0c9393..970c6b97d 100644
--- a/src/submodules/STMassMatrix/src/STMM_28.inc
+++ b/src/submodules/STMassMatrix/src/STMM_28.inc
@@ -40,8 +40,8 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
-CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+CALL getInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMM_5.inc b/src/submodules/STMassMatrix/src/STMM_5.inc
index b536a0c53..ec5057b7d 100644
--- a/src/submodules/STMassMatrix/src/STMM_5.inc
+++ b/src/submodules/STMassMatrix/src/STMM_5.inc
@@ -40,7 +40,7 @@ PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt)
!!
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=rho)
+ CALL getInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
diff --git a/src/submodules/STMassMatrix/src/STMM_6.inc b/src/submodules/STMassMatrix/src/STMM_6.inc
index 9424215c7..738cd9102 100644
--- a/src/submodules/STMassMatrix/src/STMM_6.inc
+++ b/src/submodules/STMassMatrix/src/STMM_6.inc
@@ -40,7 +40,7 @@ PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt)
!!
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=rho)
+ CALL getInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
diff --git a/src/submodules/STMassMatrix/src/STMM_7.inc b/src/submodules/STMassMatrix/src/STMM_7.inc
index 8474fde1e..fa33dc83f 100644
--- a/src/submodules/STMassMatrix/src/STMM_7.inc
+++ b/src/submodules/STMassMatrix/src/STMM_7.inc
@@ -45,7 +45,7 @@ PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt)
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL getInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
diff --git a/src/submodules/STMassMatrix/src/STMM_8.inc b/src/submodules/STMassMatrix/src/STMM_8.inc
index 326e32b62..9a70ec6da 100644
--- a/src/submodules/STMassMatrix/src/STMM_8.inc
+++ b/src/submodules/STMassMatrix/src/STMM_8.inc
@@ -40,7 +40,7 @@ PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt)
!!
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=rho)
+ CALL getInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
diff --git a/src/submodules/STMassMatrix/src/STMM_9.inc b/src/submodules/STMassMatrix/src/STMM_9.inc
index 9d6980288..e0c430927 100644
--- a/src/submodules/STMassMatrix/src/STMM_9.inc
+++ b/src/submodules/STMassMatrix/src/STMM_9.inc
@@ -37,7 +37,7 @@ INTEGER(I4B) :: ipt, ips, a, b
!!
!! main
!!
-CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90 b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90
index 78aa30ae6..6ddfc9355 100644
--- a/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90
+++ b/src/submodules/STMassMatrix/src/STMassMatrix_Method@Methods.F90
@@ -206,7 +206,7 @@ PURE SUBROUTINE STMM_5(ans, test, trial, term1, term2, rho, opt)
!!
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=rho)
+ CALL getInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
@@ -255,7 +255,7 @@ PURE SUBROUTINE STMM_6(ans, test, trial, term1, term2, rho, opt)
!!
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=rho)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
@@ -309,7 +309,7 @@ PURE SUBROUTINE STMM_7(ans, test, trial, term1, term2, rho, opt)
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
- CALL getInterpolation(obj=trial, interpol=rhobar, val=rho)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
@@ -358,7 +358,7 @@ PURE SUBROUTINE STMM_8(ans, test, trial, term1, term2, rho, opt)
!!
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=rho)
+ CALL GetInterpolation(obj=trial, ans=rhobar, val=rho)
!!
DO ipt = 1, SIZE(trial)
realval = trial(ipt)%js * trial(ipt)%ws * trial(ipt)%thickness * &
@@ -405,7 +405,7 @@ PURE SUBROUTINE STMM_9a(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -466,7 +466,7 @@ PURE SUBROUTINE STMM_9b(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -527,7 +527,7 @@ PURE SUBROUTINE STMM_9c(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -588,7 +588,7 @@ PURE SUBROUTINE STMM_9d(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -651,7 +651,7 @@ PURE SUBROUTINE STMM_10a(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -724,7 +724,7 @@ PURE SUBROUTINE STMM_10b(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -797,7 +797,7 @@ PURE SUBROUTINE STMM_10c(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -871,7 +871,7 @@ PURE SUBROUTINE STMM_10d(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -943,7 +943,7 @@ PURE SUBROUTINE STMM_11a(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1010,7 +1010,7 @@ PURE SUBROUTINE STMM_11b(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1076,7 +1076,7 @@ PURE SUBROUTINE STMM_11c(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1144,7 +1144,7 @@ PURE SUBROUTINE STMM_11d(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1215,7 +1215,7 @@ PURE SUBROUTINE STMM_12a(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
@@ -1284,7 +1284,7 @@ PURE SUBROUTINE STMM_12b(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
@@ -1353,7 +1353,7 @@ PURE SUBROUTINE STMM_12c(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
@@ -1422,7 +1422,7 @@ PURE SUBROUTINE STMM_12d(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=vbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=vbar, val=rho)
!!
CALL Reallocate(m6, &
@@ -1486,7 +1486,7 @@ PURE SUBROUTINE STMM_13(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1540,7 +1540,7 @@ PURE SUBROUTINE STMM_14(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1602,7 +1602,7 @@ PURE SUBROUTINE STMM_15(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -1658,7 +1658,7 @@ PURE SUBROUTINE STMM_16(ans, test, trial, term1, term2, rho)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=kbar, val=rho)
+ CALL getInterpolation(obj=trial, ans=kbar, val=rho)
!!
CALL Reallocate(m6, &
@@ -1730,8 +1730,8 @@ PURE SUBROUTINE STMM_17(ans, test, trial, term1, term2, c1, c2, opt)
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
- CALL GetInterpolation(obj=trial, interpol=m2, val=c1)
- CALL GetInterpolation(obj=trial, interpol=m2b, val=c2)
+ CALL GetInterpolation(obj=trial, ans=m2, val=c1)
+ CALL GetInterpolation(obj=trial, ans=m2b, val=c2)
!!
DO ipt = 1, SIZE(trial)
!!
@@ -1790,8 +1790,8 @@ PURE SUBROUTINE STMM_18(ans, test, trial, term1, term2, c1, c2, opt)
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
- CALL GetInterpolation(obj=trial, interpol=m2, val=c1)
- CALL GetInterpolation(obj=trial, interpol=m2b, val=c2)
+ CALL GetInterpolation(obj=trial, ans=m2, val=c1)
+ CALL GetInterpolation(obj=trial, ans=m2b, val=c2)
!!
DO ipt = 1, SIZE(trial)
!!
@@ -1850,8 +1850,8 @@ PURE SUBROUTINE STMM_19(ans, test, trial, term1, term2, c1, c2, opt)
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
- CALL GetInterpolation(obj=trial, interpol=m2, val=c1)
- CALL GetInterpolation(obj=trial, interpol=m2b, val=c2)
+ CALL GetInterpolation(obj=trial, ans=m2, val=c1)
+ CALL GetInterpolation(obj=trial, ans=m2b, val=c2)
!!
DO ipt = 1, SIZE(trial)
!!
@@ -1910,8 +1910,8 @@ PURE SUBROUTINE STMM_20(ans, test, trial, term1, term2, c1, c2, opt)
& SIZE(trial(1)%N, 1), &
& SIZE(trial(1)%T))
!!
- CALL GetInterpolation(obj=trial, interpol=m2, val=c1)
- CALL GetInterpolation(obj=trial, interpol=m2b, val=c2)
+ CALL GetInterpolation(obj=trial, ans=m2, val=c1)
+ CALL GetInterpolation(obj=trial, ans=m2b, val=c2)
!!
DO ipt = 1, SIZE(trial)
!!
@@ -1964,8 +1964,8 @@ PURE SUBROUTINE STMM_21a(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2028,8 +2028,8 @@ PURE SUBROUTINE STMM_21b(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2092,8 +2092,8 @@ PURE SUBROUTINE STMM_21c(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2156,8 +2156,8 @@ PURE SUBROUTINE STMM_21d(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2222,8 +2222,8 @@ PURE SUBROUTINE STMM_22a(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2297,8 +2297,8 @@ PURE SUBROUTINE STMM_22b(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2372,8 +2372,8 @@ PURE SUBROUTINE STMM_22c(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2447,8 +2447,8 @@ PURE SUBROUTINE STMM_22d(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2521,8 +2521,8 @@ PURE SUBROUTINE STMM_23a(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2591,8 +2591,8 @@ PURE SUBROUTINE STMM_23b(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2661,8 +2661,8 @@ PURE SUBROUTINE STMM_23c(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2731,8 +2731,8 @@ PURE SUBROUTINE STMM_23d(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=vbar, val=c2)
+ CALL getInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL getInterpolation(obj=trial, ans=vbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2864,8 +2864,8 @@ PURE SUBROUTINE STMM_25(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+ CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2923,8 +2923,8 @@ PURE SUBROUTINE STMM_26(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+ CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -2989,8 +2989,8 @@ PURE SUBROUTINE STMM_27(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+ CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
@@ -3049,8 +3049,8 @@ PURE SUBROUTINE STMM_28(ans, test, trial, term1, term2, c1, c2)
!!
!! main
!!
- CALL getInterpolation(obj=trial, interpol=c1bar, val=c1)
- CALL getInterpolation(obj=trial, interpol=kbar, val=c2)
+ CALL GetInterpolation(obj=trial, ans=c1bar, val=c1)
+ CALL GetInterpolation(obj=trial, ans=kbar, val=c2)
!!
CALL Reallocate(m6, &
& SIZE(test(1)%N, 1), &
diff --git a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90 b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90
index 11e983a30..8e675cde2 100644
--- a/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90
+++ b/src/submodules/StiffnessMatrix/src/StiffnessMatrix_Method@Methods.F90
@@ -36,7 +36,7 @@
nsd = SIZE(trial%dNdXt, 2)
CALL Reallocate(ans, nns1 * nsd, nns2 * nsd)
-CALL GetInterpolation(obj=test, interpol=CBar, val=Cijkl)
+CALL GetInterpolation(obj=test, ans=CBar, val=Cijkl)
SELECT CASE (nsd)
CASE (1)
@@ -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, ans=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
!----------------------------------------------------------------------------
@@ -117,8 +179,8 @@
ALLOCATE (ans(nns1 * nsd, nns2 * nsd))
ans = 0.0_DFP
-CALL GetInterpolation(obj=test, interpol=lambdaBar, val=lambda0)
-CALL GetInterpolation(obj=test, interpol=muBar, val=mu)
+CALL GetInterpolation(obj=test, ans=lambdaBar, val=lambda0)
+CALL GetInterpolation(obj=test, ans=muBar, val=mu)
CALL Reallocate(realval, nips)
realval = trial%ws * trial%js * trial%thickness
@@ -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, ans=lambdaBar, val=lambda0, tsize=ii)
+CALL GetInterpolation_(obj=test, ans=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) :: indx(3, 3)
+
+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/Tetrahedron/CMakeLists.txt b/src/submodules/Tetrahedron/CMakeLists.txt
new file mode 100644
index 000000000..d17c7ce56
--- /dev/null
+++ b/src/submodules/Tetrahedron/CMakeLists.txt
@@ -0,0 +1,23 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferenceTetrahedron_Method@Methods.F90
+ ${src_path}/TetrahedronInterpolationUtility@Methods.F90
+ ${src_path}/Tetrahedron_QuadraturePoint_Solin.F90)
diff --git a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90 b/src/submodules/Tetrahedron/src/ReferenceTetrahedron_Method@Methods.F90
similarity index 93%
rename from src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90
rename to src/submodules/Tetrahedron/src/ReferenceTetrahedron_Method@Methods.F90
index 1e84e2ad5..b2c9a0b47 100644
--- a/src/submodules/Geometry/src/ReferenceTetrahedron_Method@Methods.F90
+++ b/src/submodules/Tetrahedron/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
!----------------------------------------------------------------------------
@@ -567,7 +570,7 @@
! GetFaceElemType
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Tetrahedron
+MODULE PROCEDURE GetFaceElemType_Tetrahedron1
INTEGER(I4B) :: elemType0
elemType0 = Input(default=Tetrahedron4, option=elemType)
@@ -603,6 +606,35 @@
IF (PRESENT(tFaceNodes)) tFaceNodes(1:4) = 21_I4B
END SELECT
-END PROCEDURE GetFaceElemType_Tetrahedron
+END PROCEDURE GetFaceElemType_Tetrahedron1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Tetrahedron2
+SELECT CASE (elemType)
+CASE (Tetrahedron4)
+ faceElemType = Triangle3
+ tFaceNodes = 3_I4B
+
+CASE (Tetrahedron10)
+ faceElemType = Triangle6
+ tFaceNodes = 6_I4B
+
+CASE (Tetrahedron20)
+ faceElemType = Triangle10
+ tFaceNodes = 10_I4B
+
+CASE (Tetrahedron35)
+ faceElemType = Triangle15
+ tFaceNodes = 15_I4B
+
+CASE (Tetrahedron56)
+ faceElemType = Triangle21
+ tFaceNodes = 21_I4B
+
+END SELECT
+END PROCEDURE GetFaceElemType_Tetrahedron2
END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90 b/src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90
similarity index 52%
rename from src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90
rename to src/submodules/Tetrahedron/src/TetrahedronInterpolationUtility@Methods.F90
index 0c0fcc3b2..1367badc1 100644
--- a/src/submodules/Polynomial/src/TetrahedronInterpolationUtility@Methods.F90
+++ b/src/submodules/Tetrahedron/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 Tetrahedron_QuadraturePoint_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/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90 b/src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90
new file mode 100644
index 000000000..750732c01
--- /dev/null
+++ b/src/submodules/Tetrahedron/src/Tetrahedron_QuadraturePoint_Solin.F90
@@ -0,0 +1,213 @@
+! 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 Tetrahedron_QuadraturePoint_Solin
+USE GlobalData, ONLY: DFP, I4B, LGT
+
+IMPLICIT NONE
+
+PRIVATE
+
+PUBLIC :: QuadraturePointTetrahedronSolin
+PUBLIC :: QuadratureOrderTetrahedronSolin
+PUBLIC :: QuadratureNumberTetrahedronSolin
+
+INTEGER(I4B), PUBLIC, PARAMETER :: MAX_ORDER_TETRAHEDRON_SOLIN = 21
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION QuadratureOrderTetrahedronSolin(nips) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: nips
+ INTEGER(I4B) :: ans
+ ans = -1
+ SELECT CASE (nips)
+ CASE (1)
+ ans = 1
+ CASE (4)
+ ans = 2
+ CASE (5)
+ ans = 3
+ CASE (11)
+ ans = 4
+ CASE (14)
+ ans = 5
+ CASE (24)
+ ans = 6
+ CASE (31)
+ ans = 7
+ CASE (43)
+ ans = 8
+ CASE (53)
+ ans = 9
+ CASE (126)
+ ans = 11
+ CASE (210)
+ ans = 13
+ CASE (330)
+ ans = 15
+ CASE (495)
+ ans = 17
+ CASE (715)
+ ans = 19
+ CASE (1001)
+ ans = 21
+ END SELECT
+END FUNCTION QuadratureOrderTetrahedronSolin
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION QuadratureNumberTetrahedronSolin(order) RESULT(ans)
+ INTEGER(I4B), INTENT(IN) :: order
+ INTEGER(I4B) :: ans
+ ans = -1
+ SELECT CASE (order)
+ CASE (0, 1)
+ ans = 1
+ CASE (2)
+ ans = 4
+ CASE (3)
+ ans = 5
+ CASE (4)
+ ans = 11
+ CASE (5)
+ ans = 14
+ CASE (6)
+ ans = 24
+ CASE (7)
+ ans = 31
+ CASE (8)
+ ans = 43
+ CASE (9)
+ ans = 53
+ CASE (10)
+ ans = 126
+ CASE (11)
+ ans = 126
+ CASE (12)
+ ans = 210
+ CASE (13)
+ ans = 210
+ CASE (14)
+ ans = 330
+ CASE (15)
+ ans = 330
+ CASE (16)
+ ans = 495
+ CASE (17)
+ ans = 495
+ CASE (18)
+ ans = 715
+ CASE (19)
+ ans = 715
+ CASE (20)
+ ans = 1001
+ CASE (21)
+ ans = 1001
+ END SELECT
+END FUNCTION QuadratureNumberTetrahedronSolin
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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)
+ CALL QP_Tetrahedron_Order1(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (2)
+ CALL QP_Tetrahedron_Order2(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (3)
+ CALL QP_Tetrahedron_Order3(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (4)
+ CALL QP_Tetrahedron_Order4(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (5)
+ CALL QP_Tetrahedron_Order5(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (6)
+ CALL QP_Tetrahedron_Order6(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (7)
+ CALL QP_Tetrahedron_Order7(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (8)
+ CALL QP_Tetrahedron_Order8(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (9)
+ CALL QP_Tetrahedron_Order9(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (10)
+ CALL QP_Tetrahedron_Order10(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (11)
+ CALL QP_Tetrahedron_Order11(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (12)
+ CALL QP_Tetrahedron_Order12(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (13)
+ CALL QP_Tetrahedron_Order13(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (14)
+ CALL QP_Tetrahedron_Order14(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (15)
+ CALL QP_Tetrahedron_Order15(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (16)
+ CALL QP_Tetrahedron_Order16(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (17)
+ CALL QP_Tetrahedron_Order17(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (18)
+ CALL QP_Tetrahedron_Order18(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (19)
+ CALL QP_Tetrahedron_Order19(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (20)
+ CALL QP_Tetrahedron_Order20(ans=ans, nrow=nrow, ncol=ncol)
+ CASE (21)
+ CALL QP_Tetrahedron_Order21(ans=ans, nrow=nrow, ncol=ncol)
+ END SELECT
+
+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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END MODULE Tetrahedron_QuadraturePoint_Solin
diff --git a/src/submodules/Tetrahedron/src/include/Tetrahedron/order1.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order1.F90
new file mode 100644
index 000000000..c787dfffe
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order10.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order10.F90
new file mode 100644
index 000000000..a82c7d727
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order11.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order11.F90
new file mode 100644
index 000000000..b91e8d3ca
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order12.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order12.F90
new file mode 100644
index 000000000..2f5998ce2
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order13.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order13.F90
new file mode 100644
index 000000000..9069c47b6
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order14.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order14.F90
new file mode 100644
index 000000000..007cf086d
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order15.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order15.F90
new file mode 100644
index 000000000..3d8499718
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order16.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order16.F90
new file mode 100644
index 000000000..dcbf7801d
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order17.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order17.F90
new file mode 100644
index 000000000..e9285b136
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order18.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order18.F90
new file mode 100644
index 000000000..874e97f62
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order19.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order19.F90
new file mode 100644
index 000000000..76002848e
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order2.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order2.F90
new file mode 100644
index 000000000..7482d5c7c
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order20.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order20.F90
new file mode 100644
index 000000000..a3655aa76
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order21.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order21.F90
new file mode 100644
index 000000000..a513352e7
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order3.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order3.F90
new file mode 100644
index 000000000..c6da40c22
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order4.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order4.F90
new file mode 100644
index 000000000..5b1a8632b
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order5.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order5.F90
new file mode 100644
index 000000000..09336ae93
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order6.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order6.F90
new file mode 100644
index 000000000..decef7a90
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order7.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order7.F90
new file mode 100644
index 000000000..a2954187c
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order8.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order8.F90
new file mode 100644
index 000000000..b5c57003b
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Tetrahedron/src/include/Tetrahedron/order9.F90 b/src/submodules/Tetrahedron/src/include/Tetrahedron/order9.F90
new file mode 100644
index 000000000..73fe78efe
--- /dev/null
+++ b/src/submodules/Tetrahedron/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/Triangle/CMakeLists.txt b/src/submodules/Triangle/CMakeLists.txt
new file mode 100644
index 000000000..d1dabf4fd
--- /dev/null
+++ b/src/submodules/Triangle/CMakeLists.txt
@@ -0,0 +1,28 @@
+# This program is a part of EASIFEM library Copyright (C) 2020-2021 Vikas
+# Sharma, Ph.D
+#
+# This program is free software: you can redistribute it and/or modify it under
+# the terms of the GNU General Public License as published by the Free Software
+# Foundation, either version 3 of the License, or (at your option) any later
+# version.
+#
+# This program is distributed in the hope that it will be useful, but WITHOUT
+# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
+# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
+# details.
+#
+# You should have received a copy of the GNU General Public License along with
+# this program. If not, see
+#
+
+set(src_path "${CMAKE_CURRENT_LIST_DIR}/src/")
+target_sources(
+ ${PROJECT_NAME}
+ PRIVATE ${src_path}/ReferenceTriangle_Method@Methods.F90
+ ${src_path}/Triangle_Method@Methods.F90
+ ${src_path}/Triangle_QuadraturePoint_Solin.F90
+ ${src_path}/TriangleInterpolationUtility@Methods.F90
+ ${src_path}/TriangleInterpolationUtility@QuadratureMethods.F90
+ ${src_path}/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
+ ${src_path}/TriangleInterpolationUtility@LagrangeBasisMethods.F90
+ ${src_path}/TriangleInterpolationUtility@OrthogonalBasisMethods.F90)
diff --git a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90 b/src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90
similarity index 95%
rename from src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90
rename to src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90
index c1bfa8f99..e1fd50232 100644
--- a/src/submodules/Geometry/src/ReferenceTriangle_Method@Methods.F90
+++ b/src/submodules/Triangle/src/ReferenceTriangle_Method@Methods.F90
@@ -25,12 +25,12 @@
USE StringUtility
USE ApproxUtility
USE ArangeUtility
-USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle, &
- & LagrangeDOF_Triangle
+USE TriangleInterpolationUtility, ONLY: InterpolationPoint_Triangle, &
+ LagrangeDOF_Triangle
USE Triangle_Method
USE InputUtility
-USE ReferenceLine_Method, ONLY: ElementType_Line, &
- & ElementOrder_Line
+USE ReferenceLine_Method, ONLY: ElementType_Line, &
+ ElementOrder_Line
USE LineInterpolationUtility, ONLY: InterpolationPoint_Line
USE MiscUtility, ONLY: Int2Str
USE Display_Method
@@ -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
!----------------------------------------------------------------------------
@@ -806,10 +808,10 @@
! GetFaceElemType_Triangle
!----------------------------------------------------------------------------
-MODULE PROCEDURE GetFaceElemType_Triangle
+MODULE PROCEDURE GetFaceElemType_Triangle1
INTEGER(I4B) :: elemType0
-elemType0 = input(default=Triangle, option=elemType)
+elemType0 = Input(default=Triangle, option=elemType)
SELECT CASE (elemType0)
@@ -840,7 +842,41 @@
END SELECT
-END PROCEDURE GetFaceElemType_Triangle
+END PROCEDURE GetFaceElemType_Triangle1
+
+!----------------------------------------------------------------------------
+! GetFaceElemType_Triangle2
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetFaceElemType_Triangle2
+SELECT CASE (elemType)
+
+CASE (Triangle3)
+ faceElemType = Line2
+ tFaceNodes = 2_I4B
+
+CASE (Triangle6)
+ faceElemType = Line3
+ tFaceNodes = 3_I4B
+
+CASE (Triangle9, Triangle10)
+ faceElemType = Line4
+ tFaceNodes = 4_I4B
+
+CASE (Triangle15)
+ faceElemType = Line5
+ tFaceNodes = 5_I4B
+
+CASE (Triangle21a, Triangle21b)
+ faceElemType = Line6
+ tFaceNodes = 6_I4B
+
+CASE (Triangle18)
+ faceElemType = Line7
+ tFaceNodes = 7_I4B
+
+END SELECT
+END PROCEDURE GetFaceElemType_Triangle2
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
new file mode 100644
index 000000000..331c293f6
--- /dev/null
+++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@HeirarchicalBasisMethods.F90
@@ -0,0 +1,1108 @@
+! 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(TriangleInterpolationUtility) HeirarchicalBasisMethods
+USE LobattoPolynomialUtility, ONLY: LobattoKernelEvalAll_, &
+ LobattoKernelGradientEvalAll_
+USE MappingUtility, ONLY: BarycentricCoordTriangle_
+
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetHierarchicalDOF_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetHierarchicalDOF_Triangle
+ans = 0
+
+SELECT CASE (opt)
+
+CASE ("v", "V")
+ ans = 3
+
+CASE ("e", "E")
+ ans = pe1 + pe2 + pe3 - 3
+
+CASE ("c", "C")
+ ans = (order - 1) * (order - 2) / 2_I4B
+
+CASE DEFAULT
+ ans = pe1 + pe2 + pe3 + (order - 1) * (order - 2) / 2_I4B
+
+END SELECT
+END PROCEDURE GetHierarchicalDOF_Triangle
+
+!----------------------------------------------------------------------------
+! 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, nrow=nrow, &
+ ncol=ncol)
+END PROCEDURE VertexBasis_Triangle
+
+!----------------------------------------------------------------------------
+! BarycentricEdgeBasis_Triangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Eval basis on edge of triangle
+!
+!# Introduction
+!
+! Evaluate basis functions on edges of triangle
+! pe1, pe2, pe3 should be greater than or equal to 2
+
+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=nrow, ncol=ncol)
+
+ 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 SUBROUTINE BarycentricEdgeBasis_Triangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 30 Oct 2022
+! summary: Evaluate the edge basis on triangle using barycentric coordinate
+! (internal only)
+
+MODULE PURE SUBROUTINE BarycentricEdgeBasis_Triangle2(pe1, pe2, pe3, &
+ lambda, phi, ans, nrow, ncol, edgeOrient1, edgeOrient2, edgeOrient3)
+ INTEGER(I4B), INTENT(IN) :: pe1
+ !! order on edge (e1)
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order on edge (e2)
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on edge (e3)
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! size(lambda,1) = 3
+ !! size(lambda,2) = number of points of evaluation
+ REAL(DFP), INTENT(IN) :: phi(1:, 0:)
+ !! lobatto kernel values
+ !! size(phi1, 1) = 3*number of points
+ !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
+ !! (lambda2-lambda1),
+ !! (lambda3-lambda2),
+ !! (lambda1-lambda3)
+ REAL(DFP), INTENT(INOUT) :: ans(:, :)
+ !! 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
+
+ !! Internal variables
+ INTEGER(I4B) :: a, ii, jj
+ REAL(DFP) :: temp, areal, o1, o2, o3
+
+ 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)
+
+ ! ans = 0.0_DFP
+ a = 0
+
+ ! edge(1) = 1 -> 2
+ DO ii = 1, pe1 - 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
+
+ DO ii = 1, pe2 - 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
+
+ DO ii = 1, pe3 - 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
+
+!----------------------------------------------------------------------------
+! EdgeBasis_Triangle
+!----------------------------------------------------------------------------
+
+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, nrow=nrow, ncol=ncol)
+END PROCEDURE EdgeBasis_Triangle
+
+!----------------------------------------------------------------------------
+! BarycentricCellBasis_Triangle
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Returns the Cell basis functions on reference Triangle
+
+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
+
+ 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
+
+ CASE (2)
+ id = 3
+ indx(1, 1) = 3
+ indx(1, 2) = 2
+
+ CASE DEFAULT
+ id = 1
+ indx(1, 1) = 1
+ indx(1, 2) = 3
+
+ 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
+!----------------------------------------------------------------------------
+
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Oct 2022
+! summary: Eval basis in the cell of reference triangle (internal only)
+
+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
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! 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
+ 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) :: 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)
+
+ cnt = 0
+
+ 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
+
+ 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
+
+END SUBROUTINE BarycentricCellBasis_Triangle2
+
+!----------------------------------------------------------------------------
+! CellBasis_Triangle
+!----------------------------------------------------------------------------
+
+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, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE CellBasis_Triangle
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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=indx(1), &
+ ncol=indx(2))
+
+ !! Vertex basis function
+ CALL BarycentricVertexBasis_Triangle(lambda=lambda, ans=ans(:, 1:3), &
+ nrow=indx(1), ncol=indx(2))
+
+ !! Edge basis function
+ ncol = ncol + indx(2)
+
+ 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)
+
+ ncol = ncol + indx(2)
+ END IF
+
+ !! 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
+
+ DEALLOCATE (phi)
+
+END SUBROUTINE BarycentricHeirarchicalBasis_Triangle
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Triangle1
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Triangle1_(order=order, pe1=pe1, pe2=pe2, pe3=pe3, &
+ xij=xij, refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Triangle1
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Triangle1_
+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_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Triangle2
+INTEGER(I4B) :: nrow, ncol
+CALL HeirarchicalBasis_Triangle2_(order=order, xij=xij, &
+ refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
+END PROCEDURE HeirarchicalBasis_Triangle2
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasis_Triangle2_
+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_
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasis_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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> 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
+
+ INTEGER(I4B) :: ii
+
+ dim1 = SIZE(lambda, 2)
+ dim2 = 3
+ dim3 = 3
+
+ 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu and Vikas Sharma, Ph. D.
+! date: 2024-04-21
+! summary: Evaluate the gradient of the edge basis on triangle
+! using barycentric coordinate
+
+PURE SUBROUTINE BarycentricEdgeBasisGradient_Triangle2(pe1, pe2, pe3, &
+ lambda, phi, gradientPhi, ans, dim1, dim2, dim3, &
+ edgeOrient1, edgeOrient2, edgeOrient3)
+ INTEGER(I4B), INTENT(IN) :: pe1
+ !! order on edge (e1)
+ INTEGER(I4B), INTENT(IN) :: pe2
+ !! order on edge (e2)
+ INTEGER(I4B), INTENT(IN) :: pe3
+ !! order on edge (e3)
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation in terms of barycentric coordinates
+ !! size(lambda,1) = 3
+ !! size(lambda,2) = number of points of evaluation
+ REAL(DFP), INTENT(IN) :: phi(1:, 0:)
+ !! lobatto kernel values
+ !! size(phi1, 1) = 3*number of points
+ !! 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
+ 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
+ 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
+
+ DO ii = 1, pe1 - 1
+ 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
+
+ DO ii = 1, pe2 - 1
+ 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(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
+
+ END DO
+
+ ! edge(3) = 3 -> 1
+ a = pe1 - 1 + pe2 - 1
+
+ DO ii = 1, pe3 - 1
+ rr(1) = o3**(ii + 1)
+ rr(2) = o3**(ii)
+
+ DO jj = 1, dim1
+ rr(3) = lambda(3, jj) * lambda(1, jj)
+
+ 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)
+
+ ans(jj, a + ii, 1) = rr(4) + rr(5)
+
+ ans(jj, a + ii, 2) = 0.0_DFP
+
+ 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)
+
+ ans(jj, a + ii, 3) = rr(4) - rr(5)
+
+ END DO
+
+ END DO
+
+END SUBROUTINE BarycentricEdgeBasisGradient_Triangle2
+
+!----------------------------------------------------------------------------
+! BarycentricCellBasisGradient_Triangle2
+!----------------------------------------------------------------------------
+
+!> author: Shion Shimizu
+! date: 2024-04-21
+! summary: Evaluate the gradient of the cell basis on triangle
+
+PURE SUBROUTINE BarycentricCellBasisGradient_Triangle2(order, lambda, phi, &
+ gradientPhi, ans, dim1, dim2, dim3, faceOrient)
+ INTEGER(I4B), INTENT(IN) :: order
+ !! order in the cell of triangle, it should be greater than 2
+ REAL(DFP), INTENT(IN) :: lambda(:, :)
+ !! point of evaluation
+ REAL(DFP), INTENT(IN) :: phi(1:, 0:)
+ !! lobatto kernel values
+ !! size(phi1, 1) = 3*number of points (lambda2-lambda1),
+ !! (lambda3-lambda1), (lambda3-lambda2)
+ !! size(phi1, 2) = max(pe1-2, pe2-2, pe3-2)+1
+ REAL(DFP), INTENT(IN) :: gradientPhi(1:, 0:)
+ !! gradients of lobatto kernel functions
+ REAL(DFP), INTENT(INOUT) :: ans(:, :, :)
+ !! 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) :: k1, k2, cnt, ii
+ REAL(DFP) :: rr(10)
+
+ dim1 = SIZE(lambda, 2)
+ dim2 = INT((order - 1) * (order - 2) / 2)
+ dim3 = 3
+
+ cnt = 0
+
+ DO k1 = 1, order - 2
+ DO k2 = 1, order - 1 - k1
+
+ cnt = cnt + 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
+
+!----------------------------------------------------------------------------
+! BarycentricHeirarchicalBasis_Triangle
+!----------------------------------------------------------------------------
+
+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=indx(1), &
+ ncol=indx(2))
+
+ CALL LobattoKernelGradientEvalAll_(n=maxP, x=d_lambda, ans=gradientPhi, &
+ nrow=indx(1), ncol=indx(2))
+
+ ! 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, :), &
+ 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
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE HeirarchicalBasisGradient_Triangle1
+INTEGER(I4B) :: s(3)
+CALL HeirarchicalBasisGradient_Triangle1_(order=order, pe1=pe1, &
+ pe2=pe2, pe3=pe3, xij=xij, refTriangle=refTriangle, ans=ans, tsize1=s(1), &
+ tsize2=s(2), tsize3=s(3))
+END PROCEDURE HeirarchicalBasisGradient_Triangle1
+
+!----------------------------------------------------------------------------
+! HeirarchicalBasisGradient_Triangle
+!----------------------------------------------------------------------------
+
+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, 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, &
+ 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")
+ jac(1, :) = [-0.50_DFP, -0.50_DFP]
+ jac(2, :) = [0.50_DFP, 0.0_DFP]
+ jac(3, :) = [0.0_DFP, 0.50_DFP]
+CASE ("U", "u")
+ jac(1, :) = [-1.0_DFP, -1.0_DFP]
+ jac(2, :) = [1.0_DFP, 0.0_DFP]
+ jac(3, :) = [0.0_DFP, 1.0_DFP]
+END SELECT
+
+DO CONCURRENT(ii=1:tsize1, jj=1:tsize2, kk=1:tsize3)
+ ans(ii, jj, kk) = dPhi(ii, jj, 1) * jac(1, kk) &
+ + dPhi(ii, jj, 2) * jac(2, kk) &
+ + dPhi(ii, jj, 3) * jac(3, kk)
+END DO
+
+DEALLOCATE (lambda, dPhi)
+
+END PROCEDURE HeirarchicalBasisGradient_Triangle2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE HeirarchicalBasisMethods
diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
new file mode 100644
index 000000000..8fb1b6a62
--- /dev/null
+++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@LagrangeBasisMethods.F90
@@ -0,0 +1,528 @@
+! 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(TriangleInterpolationUtility) LagrangeBasisMethods
+USE LagrangePolynomialUtility, ONLY: LagrangeVandermonde_
+USE InputUtility, ONLY: Input
+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
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Triangle
+INTEGER(I4B) :: nrow, ncol
+nrow = (order + 1) * (order + 2) / 2_I4B
+ncol = 2
+ALLOCATE (ans(nrow, ncol))
+CALL LagrangeDegree_Triangle_(order=order, ans=ans, ncol=ncol, nrow=nrow)
+END PROCEDURE LagrangeDegree_Triangle
+
+!----------------------------------------------------------------------------
+! LagrangeDegree_Triangle_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDegree_Triangle_
+INTEGER(I4B) :: ii, jj, kk
+
+nrow = (order + 1) * (order + 2) / 2_I4B
+ncol = 2
+
+kk = 0
+DO jj = 0, order
+ DO ii = 0, order - jj
+ kk = kk + 1
+ ans(kk, 1) = ii
+ ans(kk, 2) = jj
+ END DO
+END DO
+
+END PROCEDURE LagrangeDegree_Triangle_
+
+!----------------------------------------------------------------------------
+! LagrangeDOF_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeDOF_Triangle
+ans = (order + 1) * (order + 2) / 2_I4B
+END PROCEDURE LagrangeDOF_Triangle
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeInDOF_Triangle
+ans = (order - 1) * (order - 2) / 2_I4B
+END PROCEDURE LagrangeInDOF_Triangle
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+
+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
+
+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=elemopt%Triangle, &
+ 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_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
+
+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_Triangle2_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Triangle3
+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
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Triangle4
+INTEGER(I4B) :: basisType0, nrow, ncol
+CHARACTER(:), ALLOCATABLE :: ref0
+
+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)
+ref0 = ""
+END PROCEDURE LagrangeCoeff_Triangle4
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle4
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Triangle4_
+SELECT CASE (basisType)
+
+CASE (polyopt%Monomial)
+ CALL LagrangeVandermonde_(order=order, xij=xij, elemType=elemopt%Triangle, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+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 (polyopt%Hierarchical)
+
+ CALL HeirarchicalBasis_Triangle_( &
+ order=order, pe1=order, pe2=order, pe3=order, xij=xij, &
+ refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
+END SELECT
+
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Triangle4_
+
+!----------------------------------------------------------------------------
+! LagrangeCoeff_Triangle4
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeCoeff_Triangle5_
+SELECT CASE (basisType)
+
+CASE (polyopt%Monomial)
+ CALL LagrangeVandermonde_Triangle_(xij=xij, degree=degree, &
+ ans=ans, nrow=nrow, ncol=ncol)
+
+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 (polyopt%Hierarchical)
+
+ CALL HeirarchicalBasis_Triangle_( &
+ order=order, pe1=order, pe2=order, pe3=order, xij=xij, &
+ refTriangle=refTriangle, ans=ans, nrow=nrow, ncol=ncol)
+END SELECT
+
+CALL GetInvMat(ans(1:nrow, 1:ncol))
+END PROCEDURE LagrangeCoeff_Triangle5_
+
+!----------------------------------------------------------------------------
+! LagrangeVandermonde
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeVandermonde_Triangle1_
+INTEGER(I4B) :: jj, ii
+
+nrow = SIZE(xij, 2)
+ncol = SIZE(degree, 1)
+
+DO CONCURRENT(ii=1:nrow, jj=1:ncol)
+ ans(ii, jj) = xij(1, ii)**degree(jj, 1) * xij(2, ii)**degree(jj, 2)
+END DO
+END PROCEDURE LagrangeVandermonde_Triangle1_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Triangle
+!----------------------------------------------------------------------------
+
+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)), &
+ x21(2, 1)
+
+tsize = 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)
+ 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)
+
+END IF
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+
+ CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=nrow, ncol=ncol)
+
+ tdof = SIZE(xij, 2)
+
+ DO ii = 1, tdof
+ xx(1, ii) = x(1)**degree(ii, 1) * x(2)**degree(ii, 2)
+ END DO
+
+CASE (polyopt%Hierarchical)
+
+ x21(1:2, 1) = x(1:2)
+ CALL HeirarchicalBasis_Triangle_(order=order, pe1=order, &
+ pe2=order, pe3=order, xij=x21, &
+ refTriangle=refTriangle, ans=xx, ncol=ncol, nrow=nrow)
+
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, &
+ polyopt%Ultraspherical)
+
+ x21(1:2, 1) = x(1:2)
+ CALL Dubiner_Triangle_(order=order, xij=x21, &
+ refTriangle=refTriangle, ans=xx, nrow=nrow, ncol=ncol)
+
+END SELECT
+
+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, 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))
+
+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=aint, ncol=bint)
+
+ END IF
+
+ coeff0(1:ncol, 1:ncol) = coeff(1:ncol, 1:ncol)
+
+ELSE
+
+ CALL LagrangeCoeff_Triangle_( &
+ order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, &
+ ans=coeff0, nrow=aint, ncol=bint)
+
+END IF
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+
+ 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 (polyopt%Hierarchical)
+
+ CALL HeirarchicalBasis_Triangle_( &
+ order=order, pe1=order, pe2=order, pe3=order, xij=x, &
+ refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint)
+
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, polyopt%Lobatto, &
+ polyopt%Ultraspherical)
+
+ CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, &
+ ans=xx, nrow=aint, ncol=bint)
+
+END SELECT
+
+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
+
+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
+ IF (firstCall0) THEN
+ CALL LagrangeCoeff_Triangle_( &
+ order=order, xij=xij, basisType=basisType0, refTriangle=refTriangle, &
+ ans=coeff, nrow=s(1), ncol=s(2))
+ END IF
+
+ 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))
+END IF
+
+SELECT CASE (basisType0)
+
+CASE (polyopt%Monomial)
+
+ CALL LagrangeDegree_Triangle_(order=order, ans=degree, nrow=s(1), ncol=s(2))
+
+ tdof = SIZE(xij, 2)
+
+ DO ii = 1, tdof
+ 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)
+ END DO
+
+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 (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))
+
+END SELECT
+
+DO ii = 1, 2
+ ! ans(:, ii, :) = TRANSPOSE(MATMUL(xx(:, :, ii), coeff0))
+ ans(1:dim1, 1:dim2, ii) = MATMUL(xx(1:dim1, 1:dim2, ii), coeff0)
+END DO
+
+END PROCEDURE LagrangeGradientEvalAll_Triangle1_
+
+!----------------------------------------------------------------------------
+! LagrangeEvalAll_Triangle_
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE LagrangeEvalAll_Triangle3_
+INTEGER(I4B) :: ii, tdof, aint, bint
+
+nrow = SIZE(x, 2)
+ncol = SIZE(xij, 2)
+
+IF (firstCall) THEN
+ CALL LagrangeCoeff_Triangle_( &
+ order=order, xij=xij, basisType=basisType, refTriangle=refTriangle, &
+ ans=coeff, nrow=aint, ncol=bint)
+END IF
+
+SELECT CASE (basisType)
+
+CASE (polyopt%Monomial)
+
+ 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 (polyopt%Hierarchical)
+
+ CALL HeirarchicalBasis_Triangle_( &
+ order=order, pe1=order, pe2=order, pe3=order, xij=x, &
+ refTriangle=refTriangle, ans=xx, nrow=aint, ncol=bint)
+
+CASE (polyopt%Jacobi, polyopt%Orthogonal, polyopt%Legendre, &
+ polyopt%Lobatto, polyopt%Ultraspherical)
+
+ CALL Dubiner_Triangle_(order=order, xij=x, refTriangle=refTriangle, &
+ ans=xx, nrow=aint, ncol=bint)
+
+END SELECT
+
+CALL GEMM(C=ans(1:nrow, 1:ncol), alpha=1.0_DFP, A=xx, B=coeff)
+END PROCEDURE LagrangeEvalAll_Triangle3_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE LagrangeBasisMethods
diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90
new file mode 100644
index 000000000..e5119a32b
--- /dev/null
+++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@Methods.F90
@@ -0,0 +1,661 @@
+! 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(TriangleInterpolationUtility) Methods
+USE BaseType, ONLY: ipopt => TypeInterpolationOpt
+USE StringUtility, ONLY: UpperCase
+USE MappingUtility, ONLY: FromUnitTriangle2Triangle_
+USE RecursiveNodesUtility, ONLY: RecursiveNode2D_
+USE Display_Method, ONLY: ToString
+USE IntegerUtility, ONLY: NumberOfTuples => SIZE
+USE LineInterpolationUtility, ONLY: EquidistanceInPoint_Line_, &
+ InterpolationPoint_Line_
+
+IMPLICIT NONE
+
+CHARACTER(*), PARAMETER :: modName = "TriangleInterpolationUtility%Methods"
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+! GetTotalDOF_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalDOF_Triangle
+ans = (order + 1) * (order + 2) / 2_I4B
+END PROCEDURE GetTotalDOF_Triangle
+
+!----------------------------------------------------------------------------
+! LagrangeInDOF_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE GetTotalInDOF_Triangle
+ans = (order - 1) * (order - 2) / 2_I4B
+END PROCEDURE GetTotalInDOF_Triangle
+
+!----------------------------------------------------------------------------
+! RefElemDomain_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE RefElemDomain_Triangle
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "RefElemDomain_Triangle()"
+#endif
+
+CHARACTER(2) :: bc
+CHARACTER(1) :: bi
+
+bc = UpperCase(baseContinuity(1:2))
+bi = UpperCase(baseInterpol(1:1))
+
+SELECT CASE (bc)
+
+CASE ("H1")
+
+ SELECT CASE (bi)
+
+ !! Lagrange ! Serendipity
+ CASE ("L", "S")
+ ans = "UNIT"
+
+ !! Hierarchical
+ CASE ("H")
+ ans = "BIUNIT"
+
+ !! Orthognal
+ CASE ("O")
+ ans = "BIUNIT"
+
+#ifdef DEBUG_VER
+ CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "No case found for given baseInterpol="//TRIM(baseInterpol))
+#endif
+
+ END SELECT
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "No case found for given baseContinuity="//TRIM(baseContinuity))
+#endif
+
+END SELECT
+
+END PROCEDURE RefElemDomain_Triangle
+
+!----------------------------------------------------------------------------
+! FacetConnectivity
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE FacetConnectivity_Triangle
+! CHARACTER(1) :: bi
+! LOGICAL(LGT) :: isok
+
+ans(1:2, 1) = [1, 2]
+ans(1:2, 2) = [2, 3]
+ans(1:2, 3) = [3, 1]
+
+! isok = PRESENT(baseInterpol)
+! bi = "L"
+! IF (isok) bi = UpperCase(baseInterpol(1:1))
+!
+! SELECT CASE (bi)
+! CASE ("H", "O")
+! ans(1:2, 1) = [1, 2]
+! ans(1:2, 2) = [1, 3]
+! ans(1:2, 3) = [2, 3]
+!
+! CASE DEFAULT
+! ans(1:2, 1) = [1, 2]
+! ans(1:2, 2) = [2, 3]
+! ans(1:2, 3) = [3, 1]
+!
+! END SELECT
+END PROCEDURE FacetConnectivity_Triangle
+
+!----------------------------------------------------------------------------
+! EquidistancePoint_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE EquidistancePoint_Triangle
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+nrow = 2
+isok = PRESENT(xij)
+IF (isok) nrow = SIZE(xij, 1)
+
+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
+LOGICAL(LGT) :: isok
+
+x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP
+
+isok = PRESENT(xij)
+
+IF (isok) THEN
+ nrow = SIZE(xij, 1)
+ x(1:nrow, 1:3) = xij(1:nrow, 1:3)
+ELSE
+ 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
+
+ncol = LagrangeDOF_Triangle(order=order)
+
+!! points on vertex
+ans(1:nrow, 1:3) = x(1:nrow, 1:3)
+
+!! points on edge
+i2 = 3
+isok = order .GT. 1_I4B
+IF (isok) THEN
+ i1 = i2 + 1
+ ! i1 = i2 + 1; i2 = i1 + ne - 1
+ CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [1, 2]), &
+ ans=ans(:, i1:), nrow=aint, ncol=bint)
+
+ i1 = i1 + bint
+ CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [2, 3]), &
+ ans=ans(:, i1:), nrow=aint, ncol=bint)
+
+ i1 = i1 + bint
+ CALL EquidistanceInPoint_Line_(order=order, xij=x(1:nrow, [3, 1]), &
+ ans=ans(:, i1:), nrow=aint, ncol=bint)
+ i2 = i1 + bint - 1
+END IF
+
+isok = order .LE. 2_I4B
+IF (isok) RETURN
+
+!! points on face
+isok = order .EQ. 3_I4B
+IF (isok) 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
+
+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
+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) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+isok = order .LT. 3_I4B
+IF (isok) THEN
+ ALLOCATE (ans(0, 0))
+ RETURN
+END IF
+
+isok = PRESENT(xij)
+nrow = 2_I4B; IF (isok) nrow = SIZE(xij, 1)
+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
+LOGICAL(LGT) :: isok
+
+nrow = 0; ncol = 0
+
+isok = order .LT. 3_I4B
+IF (isok) RETURN
+
+x = 0.0_DFP; xin = 0.0_DFP; e1 = 0.0_DFP; e2 = 0.0_DFP
+
+isok = PRESENT(xij)
+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]
+IF (isok) THEN
+ nrow = SIZE(xij, 1)
+ x(1:nrow, 1:3) = xij(1:nrow, 1:3)
+END IF
+
+ncol = LagrangeInDOF_Triangle(order=order)
+
+!! points on face
+isok = order .EQ. 3_I4B
+IF (isok) THEN
+ ans(1:nrow, 1) = (x(1:nrow, 1) + x(1:nrow, 2) + x(1:nrow, 3)) / 3.0_DFP
+ RETURN
+END IF
+
+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
+INTEGER(I4B) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+isok = PRESENT(xij)
+ncol = LagrangeDOF_Triangle(order=order)
+nrow = 2; IF (isok) 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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE BlythPozrikidis_Triangle_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "BlythPozrikidis_Triangle_()"
+#endif
+
+INTEGER(I4B), PARAMETER :: max_order = 30
+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)
+
+INTEGER(I4B) :: ii, jj, kk, tsize
+
+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
+ kk = order + 3 - ii - jj
+ xi(ii, jj) = (1.0 + 2.0 * v(ii) - v(jj) - v(kk)) / 3.0_DFP
+ eta(ii, jj) = (1.0 + 2.0 * v(jj) - v(ii) - v(kk)) / 3.0_DFP
+ END DO
+END DO
+
+SELECT CASE (layout)
+
+CASE ("VEFC")
+
+ 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
+
+ ans(1:2, 1:ncol) = temp(1:2, 1:ncol)
+
+#ifdef DEBUG_VER
+CASE DEFAULT
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "layout=VEFC is allowed, found layout is "//TRIM(layout))
+#endif
+
+END SELECT
+
+END PROCEDURE BlythPozrikidis_Triangle_
+
+!----------------------------------------------------------------------------
+! Isaac_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Isaac_Triangle
+INTEGER(I4B) :: nrow, ncol
+
+ncol = NumberOfTuples(n=order, d=2)
+nrow = 2; IF (PRESENT(xij)) nrow = SIZE(xij, 1)
+
+ALLOCATE (ans(nrow, ncol))
+
+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_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "Isaac_Triangle()"
+#endif
+
+INTEGER(I4B), PARAMETER :: max_order = 30
+LOGICAL(LGT) :: isok
+REAL(DFP) :: xi(max_order + 1, max_order + 1), &
+ eta(max_order + 1, max_order + 1), &
+ temp(2, 512)
+
+! 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)
+
+isok = PRESENT(xij)
+IF (isok) nrow = SIZE(xij, 1)
+
+!! convert from rPoints to xi and eta
+cnt = 0
+xi(1:nn, 1:nn) = 0.0_DFP
+eta(1:nn, 1:nn) = 0.0_DFP
+
+DO ii = 1, nn
+ DO jj = 1, nn + 1 - ii
+ cnt = cnt + 1
+ xi(ii, jj) = temp(1, cnt)
+ eta(ii, jj) = temp(2, cnt)
+ END DO
+END DO
+
+isok = layout .EQ. "VEFC"
+IF (isok) THEN
+ CALL IJ2VEFC_Triangle(xi=xi, eta=eta, temp=temp, order=order, N=ncol)
+
+ IF (PRESENT(xij)) THEN
+ CALL FromUnitTriangle2Triangle_( &
+ xin=temp(:, 1:ncol), ans=ans, nrow=nrow, ncol=ncol, x1=xij(:, 1), &
+ x2=xij(:, 2), x3=xij(:, 3))
+ RETURN
+ END IF
+
+ ans(1:nrow, 1:ncol) = temp(1:nrow, 1:ncol)
+ RETURN
+END IF
+
+#ifdef DEBUG_VER
+CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "Only layout=VEFC is allowed, found layout is "//layout)
+#endif
+END PROCEDURE Isaac_Triangle_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE IJ2VEFC_Triangle
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "IJ2VEFC_Triangle()"
+#endif
+
+LOGICAL(LGT) :: isok
+INTEGER(I4B) :: cnt, m, ii, jj, ll, llt, llr
+
+cnt = 0
+m = order
+llt = INT((m - 1) / 3)
+llr = MOD(m - 1, 3)
+DO ll = 0, llt
+ !! v1
+ cnt = cnt + 1
+ ii = 1 + ll; jj = 1 + ll
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ !! v2
+ cnt = cnt + 1
+ ii = m + 1 - 2 * ll; jj = 1 + ll
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ !! v3
+ cnt = cnt + 1
+ ii = 1 + ll; jj = m + 1 - 2 * ll
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ !! nodes on edge 12
+ jj = ll + 1
+ DO ii = 2 + ll, m - 2 * ll
+ cnt = cnt + 1
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ END DO
+ !! nodes on edge 23
+ DO jj = 2 + ll, m - 2 * ll
+ cnt = cnt + 1
+ ii = m - ll + 2 - jj
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ END DO
+ !! nodes on edge 31
+ ii = ll + 1
+ DO jj = m - 2 * ll, 2 + ll, -1
+ cnt = cnt + 1
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+ END DO
+ !! internal nodes
+END DO
+
+isok = llr .EQ. 2_I4B
+IF (isok) THEN
+ !! a internal point
+ cnt = cnt + 1
+ ll = llt + 1
+ ii = 1 + ll; jj = 1 + ll
+ temp(1, cnt) = xi(ii, jj)
+ temp(2, cnt) = eta(ii, jj)
+END IF
+
+#ifdef DEBUG_VER
+isok = cnt .EQ. N
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "cnt="//ToString(cnt)//" not equal to total DOF, N="// &
+ ToString(N))
+#endif
+
+END PROCEDURE IJ2VEFC_Triangle
+
+!----------------------------------------------------------------------------
+! InterpolationPoint_Triangle
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE InterpolationPoint_Triangle
+INTEGER(I4B) :: nrow, ncol
+
+IF (PRESENT(xij)) THEN
+ nrow = SIZE(xij, 1)
+ELSE
+ nrow = 2
+END IF
+
+SELECT CASE (ipType)
+CASE (ipopt%Equidistance, ipopt%BlythPozChebyshev, ipopt%BlythPozLegendre)
+ ncol = LagrangeDOF_Triangle(order=order)
+
+CASE (ipopt%IsaacLegendre, ipopt%IsaacChebyshev, &
+ ipopt%GaussLegendreLobatto, ipopt%GaussChebyshevLobatto)
+ ncol = NumberOfTuples(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_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "InterpolationPoint_Triangle_()"
+#endif
+
+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)
+
+#ifdef DEBUG_VER
+ CALL AssertError1(.FALSE., myName, modName, __LINE__, &
+ "Feket, Hesthaven, ChenBabuska nodes not available")
+#endif
+
+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_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE Methods
diff --git a/src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90
similarity index 100%
rename from src/submodules/Polynomial/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90
rename to src/submodules/Triangle/src/TriangleInterpolationUtility@OrthogonalBasisMethods.F90
diff --git a/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90 b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90
new file mode 100644
index 000000000..42816de22
--- /dev/null
+++ b/src/submodules/Triangle/src/TriangleInterpolationUtility@QuadratureMethods.F90
@@ -0,0 +1,320 @@
+! 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(TriangleInterpolationUtility) QuadratureMethods
+USE Triangle_QuadraturePoint_Solin, ONLY: QuadraturePointTriangleSolin, &
+ QuadraturePointTriangleSolin_, &
+ QuadratureNumberTriangleSolin
+USE BaseType, ONLY: TypeQuadratureOpt
+USE StringUtility, ONLY: UpperCase
+USE QuadrangleInterpolationUtility, ONLY: QuadraturePoint_Quadrangle_
+USE MappingUtility, ONLY: FromSquare2Triangle_, &
+ FromUnitTriangle2Triangle_, &
+ JacobianTriangle, &
+ FromTriangle2Triangle_
+
+IMPLICIT NONE
+
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: modName = &
+ "TriangleInterpolationUtility@QuadratureMethods"
+#endif
+
+CONTAINS
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadratureNumber_Triangle
+LOGICAL(LGT) :: isok
+
+ans = QuadratureNumberTriangleSolin(order=order)
+
+isok = ans .LE. 0
+IF (isok) 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) :: nipsx(1), nipsy(1), nrow, ncol
+LOGICAL(LGT) :: isok
+
+nrow = 1_I4B + INT(order / 2, kind=I4B)
+nipsx(1) = nrow + 1
+nipsy(1) = nrow
+
+nrow = 2_I4B
+isok = PRESENT(xij)
+IF (isok) nrow = MAX(SIZE(xij, 1), 2_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_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) :: nrow, ncol
+LOGICAL(LGT) :: isok
+
+nrow = 2_I4B
+isok = PRESENT(xij)
+IF (isok) nrow = MAX(SIZE(xij, 1), 2_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
+LOGICAL(LGT) :: isok
+CHARACTER(1) :: astr
+
+nsd = 2_I4B
+isok = PRESENT(xij)
+IF (isok) nsd = MAX(SIZE(xij, 1), 2_I4B)
+
+nrow = nsd + 1_I4B
+ncol = nipsx(1) * nipsy(1)
+
+CALL QuadraturePoint_Quadrangle_( &
+ nipsx=nipsx, nipsy=nipsy, &
+ quadType1=TypeQuadratureOpt%GaussLegendreLobatto, &
+ quadType2=TypeQuadratureOpt%GaussJacobiRadauLeft, &
+ refQuadrangle="BIUNIT", alpha2=1.0_DFP, beta2=0.0_DFP, &
+ ans=ans, nrow=ii, ncol=jj)
+
+! 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")
+
+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
+
+astr = UpperCase(refTriangle(1:1))
+
+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) :: 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
+ CALL TensorQuadraturepoint_Triangle_( &
+ order=order, quadtype=quadtype, reftriangle=reftriangle, xij=xij, &
+ ans=ans, nrow=nrow, ncol=ncol)
+ RETURN
+END IF
+
+CALL QuadraturePoint_Triangle2_( &
+ nips=nips, quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
+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) nrow = SIZE(xij, 1)
+
+nrow = nrow + 1
+ncol = nips(1)
+
+ALLOCATE (ans(nrow, ncol))
+
+CALL QuadraturePoint_Triangle2_( &
+ nips=nips, quadType=quadType, refTriangle=refTriangle, xij=xij, ans=ans, &
+ nrow=nrow, ncol=ncol)
+END PROCEDURE QuadraturePoint_Triangle2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE QuadraturePoint_Triangle2_
+#ifdef DEBUG_VER
+CHARACTER(*), PARAMETER :: myName = "QuadraturePoint_Triangle2_()"
+#endif
+
+INTEGER(I4B) :: nsd, ii, jj
+LOGICAL(LGT) :: isok
+REAL(DFP) :: areal
+CHARACTER(1) :: astr
+
+nrow = 0
+ncol = 0
+
+ii = QuadratureNumberTriangleSolin(order=20)
+
+#ifdef DEBUG_VER
+isok = nips(1) .LE. ii
+CALL AssertError1(isok, myName, modName, __LINE__, &
+ "This routine should be called for economical quadrature points only,&
+ &otherwise call QuadraturePoint_Triangle1()")
+#endif
+
+nsd = 2_I4B
+isok = PRESENT(xij)
+IF (isok) nsd = SIZE(xij, 1)
+
+nrow = nsd + 1
+ncol = nips(1)
+
+CALL QuadraturePointTriangleSolin_(nips=nips, ans=ans, nrow=ii, ncol=jj)
+
+IF (isok) THEN
+ 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
+
+astr = UpperCase(reftriangle(1:1))
+isok = astr == "B"
+
+IF (isok) THEN
+ CALL FromTriangle2Triangle_(xin=ans(1:2, 1:ncol), ans=ans, &
+ from="U", to="B", nrow=ii, ncol=jj)
+
+ 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 QuadraturePoint_Triangle2_
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+#include "../../include/errors.F90"
+
+END SUBMODULE QuadratureMethods
diff --git a/src/submodules/Geometry/src/Triangle_Method@Methods.F90 b/src/submodules/Triangle/src/Triangle_Method@Methods.F90
similarity index 86%
rename from src/submodules/Geometry/src/Triangle_Method@Methods.F90
rename to src/submodules/Triangle/src/Triangle_Method@Methods.F90
index 70337ee7d..33140c4e0 100644
--- a/src/submodules/Geometry/src/Triangle_Method@Methods.F90
+++ b/src/submodules/Triangle/src/Triangle_Method@Methods.F90
@@ -16,7 +16,22 @@
!
SUBMODULE(Triangle_Method) Methods
-USE BaseMethod
+! USE BaseMethod
+USE SwapUtility, ONLY: Swap
+USE MiscUtility, ONLY: safe_ACOS
+USE Line_Method, ONLY: line_exp_is_degenerate_nd, &
+ line_exp2imp_2d, &
+ lines_imp_int_2d, &
+ line_exp_perp_2d, &
+ lines_exp_int_2d, &
+ segment_point_dist_2d, &
+ segment_point_dist_3d, &
+ line_exp_point_dist_signed_2d, &
+ segment_point_near_2d
+
+USE Plane_Method, ONLY: plane_normal_line_exp_int_3d
+
+USE Random_Method, ONLY: rvec_uniform_01
IMPLICIT NONE
CONTAINS
@@ -524,7 +539,7 @@
! Find the intersection of the plane and the line.
!
CALL plane_normal_line_exp_int_3d(t(1:dim_num, 1), normal, p1, p2, &
- & ival, pint)
+ ival, pint)
!
IF (ival == 0) THEN
inside = .FALSE.
@@ -1303,7 +1318,7 @@
DO j = 1, side_num
jp1 = i4_wrap(j + 1, 1, side_num)
CALL segment_point_near_2d(t(1:dim_num, j), t(1:dim_num, jp1), p, &
- & pn2, dist2, tval)
+ pn2, dist2, tval)
IF (dist2 < dist) THEN
dist = dist2
pn(1:dim_num) = pn2(1:dim_num)
@@ -1426,7 +1441,224 @@
!
!----------------------------------------------------------------------------
-#include "./inc/aux.inc"
+!> author: Vikas Sharma, Ph. D.
+! date: 28 Aug 2022
+! summary: r8mat solve
+!
+!# Introduction
+!
+! Input, integer ( kind = 4 ) N, the order of the matrix.
+!
+! Input, integer ( kind = 4 ) RHS_NUM, the number of right hand sides.
+! RHS_NUM must be at least 0.
+!
+! Input/output, real ( kind = 8 ) A(N,N+rhs_num), contains in rows and
+! columns 1 to N the coefficient matrix, and in columns N+1 through
+! N+rhs_num, the right hand sides. On output, the coefficient matrix
+! area has been destroyed, while the right hand sides have
+! been overwritten with the corresponding solutions.
+!
+! Output, integer ( kind = 4 ) INFO, singularity flag.
+! 0, the matrix was not singular, the solutions were computed;
+! J, factorization failed on step J, and the solutions could not
+! be computed.
+
+PURE SUBROUTINE r8mat_solve(n, rhs_num, a, info)
+ INTEGER(I4B), INTENT(IN) :: n
+ INTEGER(I4B), INTENT(IN) :: rhs_num
+ REAL(DFP), INTENT(INOUT) :: a(n, n + rhs_num)
+ INTEGER(I4B), INTENT(OUT) :: info
+ !!
+ REAL(DFP) :: apivot
+ REAL(DFP) :: factor
+ INTEGER(I4B) :: i
+ INTEGER(I4B) :: ipivot
+ INTEGER(I4B) :: j
+ !!
+ info = 0
+ !!
+ DO j = 1, n
+ !
+ ! Choose a pivot row.
+ !
+ ipivot = j
+ apivot = a(j, j)
+ !
+ DO i = j + 1, n
+ IF (ABS(apivot) < ABS(a(i, j))) THEN
+ apivot = a(i, j)
+ ipivot = i
+ END IF
+ END DO
+ !
+ IF (apivot == 0.0D+00) THEN
+ info = j
+ RETURN
+ END IF
+ !
+ ! Interchange.
+ !
+ DO i = 1, n + rhs_num
+ CALL swap(a(ipivot, i), a(j, i))
+ END DO
+ !
+ ! A(J,J) becomes 1.
+ !
+ a(j, j) = 1.0D+00
+ a(j, j + 1:n + rhs_num) = a(j, j + 1:n + rhs_num) / apivot
+ !
+ ! A(I,J) becomes 0.
+ !
+ DO i = 1, n
+ IF (i /= j) THEN
+ factor = a(i, j)
+ a(i, j) = 0.0D+00
+ a(i,j+1:n+rhs_num) = a(i,j+1:n+rhs_num) - factor * a(j,j+1:n+rhs_num)
+ END IF
+ END DO
+ END DO
+END SUBROUTINE r8mat_solve
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION r8vec_normsq_affine(n, v0, v1) RESULT(ans)
+ INTEGER(i4b), INTENT(in) :: n
+ REAL(dfp), INTENT(in) :: v0(n)
+ REAL(dfp), INTENT(in) :: v1(n)
+ REAL(dfp) :: ans
+ ans = SUM((v0(1:n) - v1(1:n))**2)
+END FUNCTION r8vec_normsq_affine
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_wrap(ival, ilo, ihi) RESULT(ans)
+ INTEGER(i4b), INTENT(in) :: ival
+ INTEGER(i4b), INTENT(in) :: ilo
+ INTEGER(i4b), INTENT(in) :: ihi
+ INTEGER(i4b) :: ans
+ !!
+ INTEGER(i4b) :: jhi
+ INTEGER(i4b) :: jlo
+ INTEGER(i4b) :: wide
+ !!
+ jlo = MIN(ilo, ihi)
+ jhi = MAX(ilo, ihi)
+ !!
+ wide = jhi - jlo + 1
+ !!
+ IF (wide == 1) THEN
+ ans = jlo
+ ELSE
+ ans = jlo + i4_modp(ival - jlo, wide)
+ END IF
+ !!
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_modp(i, j) RESULT(ans)
+ INTEGER(i4b), INTENT(IN) :: i
+ INTEGER(i4b), INTENT(IN) :: j
+ INTEGER(i4b) :: ans
+ IF (j == 0) THEN
+ RETURN
+ END IF
+ ans = MOD(i, j)
+ IF (ans < 0) THEN
+ ans = ans + ABS(j)
+ END IF
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4vec_lcm(n, v)
+ INTEGER(i4b), INTENT(in) :: n
+ INTEGER(i4b), INTENT(in) :: v(n)
+ INTEGER(i4b) :: i4vec_lcm
+ INTEGER(i4b) :: i
+ INTEGER(i4b) :: lcm
+ !
+ lcm = 1
+ DO i = 1, n
+ IF (v(i) == 0) THEN
+ lcm = 0
+ i4vec_lcm = lcm
+ RETURN
+ END IF
+ lcm = i4_lcm(lcm, v(i))
+ END DO
+ i4vec_lcm = lcm
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_lcm(i, j)
+ INTEGER(i4b), INTENT(in) :: i, j
+ INTEGER(I4B) :: i4_lcm
+ i4_lcm = ABS(i * (j / i4_gcd(i, j)))
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION i4_gcd(i, j)
+ INTEGER(I4B), INTENT(IN) :: i, j
+ INTEGER(I4B) :: i4_gcd
+ !!
+ INTEGER(kind=4) p
+ INTEGER(kind=4) q
+ INTEGER(kind=4) r
+ !
+ i4_gcd = 1
+ !
+ ! Return immediately if either I or J is zero.
+ !
+ IF (i == 0) THEN
+ i4_gcd = MAX(1, ABS(j))
+ RETURN
+ ELSE IF (j == 0) THEN
+ i4_gcd = MAX(1, ABS(i))
+ RETURN
+ END IF
+ !
+ ! Set P to the larger of I and J, Q to the smaller.
+ ! This way, we can alter P and Q as we go.
+ !
+ p = MAX(ABS(i), ABS(j))
+ q = MIN(ABS(i), ABS(j))
+ !
+ ! Carry out the Euclidean algorithm.
+ !
+ DO
+ r = MOD(p, q)
+ IF (r == 0) THEN
+ EXIT
+ END IF
+ p = q
+ q = r
+ END DO
+ i4_gcd = q
+END FUNCTION
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+PURE FUNCTION r8_huge()
+ REAL(dfp) :: r8_huge
+ r8_huge = 1.0D+30
+END FUNCTION
!----------------------------------------------------------------------------
!
diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90 b/src/submodules/Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90
similarity index 99%
rename from src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90
rename to src/submodules/Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90
index 58f5d1310..554e2550c 100644
--- a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_InternalUseOnly.F90
+++ b/src/submodules/Triangle/src/Triangle_QuadraturePoint_InternalUseOnly.F90
@@ -71,7 +71,7 @@
! ISBN: 0750663200,
! LC: TA640.2.Z54
-module QuadraturePoint_Triangle_InternalUseOnly
+module Triangle_QuadraturePoint_InternalUseOnly
USE GlobalData, only: DFP
implicit none
private
@@ -472,6 +472,4 @@ module QuadraturePoint_Triangle_InternalUseOnly
!!TOMS706_37, order 37, degree of precision 13, a rule from ACM TOMS algorithm 706.
-
-
-end module QuadraturePoint_Triangle_InternalUseOnly
+end module Triangle_QuadraturePoint_InternalUseOnly
diff --git a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90 b/src/submodules/Triangle/src/Triangle_QuadraturePoint_Solin.F90
similarity index 99%
rename from src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90
rename to src/submodules/Triangle/src/Triangle_QuadraturePoint_Solin.F90
index 9e154630b..b865dd970 100644
--- a/src/submodules/Polynomial/src/QuadraturePoint_Triangle_Solin.F90
+++ b/src/submodules/Triangle/src/Triangle_QuadraturePoint_Solin.F90
@@ -19,9 +19,10 @@
! https://gitlab.onelab.info/gmsh/gmsh/-/blame/master/src/numeric/GaussQuadratureTri.cpp#L28
! 'Higher-order Finite Elements', P.Solin, K.Segeth and I. Dolezel */
-module QuadraturePoint_Triangle_Solin
+module Triangle_QuadraturePoint_Solin
USE GlobalData, only: DFP, I4B
-implicit none
+implicit none
+
private
public :: QuadratureNumberTriangleSolin
public :: QuadraturePointTriangleSolin
@@ -2167,4 +2168,4 @@ pure subroutine QuadraturePointTriangleSolin_(nips, ans, nrow, ncol)
end select
end subroutine QuadraturePointTriangleSolin_
-END MODULE QuadraturePoint_Triangle_Solin
+END MODULE Triangle_QuadraturePoint_Solin
diff --git a/src/submodules/Utility/CMakeLists.txt b/src/submodules/Utility/CMakeLists.txt
index c67eb1a0d..0140713b6 100644
--- a/src/submodules/Utility/CMakeLists.txt
+++ b/src/submodules/Utility/CMakeLists.txt
@@ -52,4 +52,5 @@ target_sources(
${src_path}/SymUtility@Methods.F90
${src_path}/TriagUtility@Methods.F90
${src_path}/LinearAlgebraUtility@Methods.F90
- ${src_path}/SafeSizeUtility@Methods.F90)
+ ${src_path}/SafeSizeUtility@Methods.F90
+ ${src_path}/ReverseUtility@Methods.F90)
diff --git a/src/submodules/Utility/src/ConvertUtility@Methods.F90 b/src/submodules/Utility/src/ConvertUtility@Methods.F90
index 658b358e7..92e4596ee 100644
--- a/src/submodules/Utility/src/ConvertUtility@Methods.F90
+++ b/src/submodules/Utility/src/ConvertUtility@Methods.F90
@@ -20,8 +20,8 @@
! summary: This submodule contains method for swaping
SUBMODULE(ConvertUtility) Methods
-USE ReallocateUtility
-USE EyeUtility
+USE ReallocateUtility, ONLY: Reallocate
+USE EyeUtility, ONLY: eye
IMPLICIT NONE
CONTAINS
@@ -29,24 +29,35 @@
! Convert
!----------------------------------------------------------------------------
-MODULE PROCEDURE convert_1
+MODULE PROCEDURE obj_Convert1
CALL Reallocate(to, nns * tdof, nns * tdof)
-CALL ConvertSafe(from=from, to=to, Conversion=conversion, &
- & nns=nns, tdof=tdof)
-END PROCEDURE convert_1
+CALL ConvertSafe(from=from, to=to, conversion=conversion, &
+ nns=nns, tdof=tdof)
+END PROCEDURE obj_Convert1
!----------------------------------------------------------------------------
! ConvertSafe
!----------------------------------------------------------------------------
-MODULE PROCEDURE convert_1_safe
+MODULE PROCEDURE obj_Convert_1
+nrow = nns * tdof
+ncol = nns * tdof
+CALL ConvertSafe(from=from, to=to(1:nrow, 1:ncol), conversion=conversion, &
+ nns=nns, tdof=tdof)
+END PROCEDURE obj_Convert_1
+
+!----------------------------------------------------------------------------
+! ConvertSafe
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_ConvertSafe1
INTEGER(I4B) :: m, inode, idof, i, j
INTEGER(I4B) :: T(nns * tdof, nns * tdof)
!> main
m = nns * tdof
T = eye(m, TypeInt)
-SELECT CASE (Conversion)
+SELECT CASE (conversion)
CASE (DofToNodes)
DO inode = 1, nns
@@ -72,13 +83,13 @@
END SELECT
to = MATMUL(TRANSPOSE(T), MATMUL(from, T))
-END PROCEDURE convert_1_safe
+END PROCEDURE obj_ConvertSafe1
!----------------------------------------------------------------------------
! Convert
!----------------------------------------------------------------------------
-MODULE PROCEDURE convert_2
+MODULE PROCEDURE obj_Convert2
! Define internal variables
INTEGER(I4B) :: a, b, I(4), r1, r2, c1, c2
I = SHAPE(From)
@@ -94,13 +105,42 @@
To(r1:r2, c1:c2) = From(:, :, a, b)
END DO
END DO
-END PROCEDURE convert_2
+END PROCEDURE obj_Convert2
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Convert_2
+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 obj_Convert_2
!----------------------------------------------------------------------------
! Convert
!----------------------------------------------------------------------------
-MODULE PROCEDURE convert_3
+MODULE PROCEDURE obj_Convert3
INTEGER(I4B) :: a, b, s(6)
REAL(DFP), ALLOCATABLE :: m2(:, :)
!!
@@ -114,7 +154,35 @@
END DO
END DO
DEALLOCATE (m2)
-END PROCEDURE convert_3
+END PROCEDURE obj_Convert3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE obj_Convert_3
+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 obj_Convert_3
!----------------------------------------------------------------------------
!
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/MatmulUtility@Methods.F90 b/src/submodules/Utility/src/MatmulUtility@Methods.F90
index 1cc31c999..600bcca39 100644
--- a/src/submodules/Utility/src/MatmulUtility@Methods.F90
+++ b/src/submodules/Utility/src/MatmulUtility@Methods.F90
@@ -28,140 +28,313 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE matmul_r4_r1
-INTEGER(I4B) :: ii
-ans = a2(1) * a1(:, :, :, 1)
-DO ii = 2, SIZE(a2)
- ans = ans + a2(ii) * a1(:, :, :, ii)
-END DO
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
END PROCEDURE matmul_r4_r1
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
-MODULE PROCEDURE matmul_r4_r2
-INTEGER(I4B) :: ii
-!!
-DO ii = 1, SIZE(a2, 2)
- ans(:,:,:,ii) = matmul(a1, a2(:,ii))
+MODULE PROCEDURE matmul_r4_r1_
+INTEGER(I4B) :: ii, jj, kk, ll
+
+dim1 = SIZE(a1, 1)
+dim2 = SIZE(a1, 2)
+dim3 = SIZE(a1, 3)
+
+ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+DO ll = 2, SIZE(a2)
+ DO kk = 1, dim3
+ DO jj = 1, dim2
+ DO ii = 1, dim1
+ ans(ii, jj, kk) = ans(ii, jj, kk) + a2(ll) * a1(ii, jj, kk, ll)
+ END DO
+ END DO
+ END DO
END DO
+END PROCEDURE matmul_r4_r1_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r4_r2
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4)
END PROCEDURE matmul_r4_r2
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
-MODULE PROCEDURE matmul_r4_r3
+MODULE PROCEDURE matmul_r4_r2_
INTEGER(I4B) :: ii
-!!
-DO ii = 1, SIZE(a2, 3)
- ans(:,:,:,:,ii) = matmul(a1, a2(:,:,ii))
+
+dim4 = SIZE(a2, 2)
+
+DO ii = 1, dim4
+ call Matmul_(a1=a1, a2=a2(:, ii), ans=ans(:,:,:,ii), dim1=dim1, dim2=dim2, &
+ dim3=dim3)
END DO
+END PROCEDURE matmul_r4_r2_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r4_r3
+INTEGER(I4B) :: dim1, dim2, dim3, dim4, dim5
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4, dim5=dim5)
END PROCEDURE matmul_r4_r3
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
-MODULE PROCEDURE matmul_r4_r4
+MODULE PROCEDURE matmul_r4_r3_
INTEGER(I4B) :: ii
-!!
-DO ii = 1, SIZE(a2, 4)
- ans(:,:,:,:,:,ii) = matmul(a1, a2(:,:,:,ii))
+
+dim5 = SIZE(a2, 3)
+
+DO ii = 1, dim5
+ CALL Matmul_(a1=a1, a2=a2(:, :, ii), ans=ans(:, :, :, :, ii), dim1=dim1, &
+ dim2=dim2, dim3=dim3, dim4=dim4)
END DO
+END PROCEDURE matmul_r4_r3_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r4_r4
+INTEGER(I4B) :: dim1, dim2, dim3, dim4, dim5, dim6
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4, dim5=dim5, dim6=dim6)
END PROCEDURE matmul_r4_r4
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
-MODULE PROCEDURE matmul_r3_r1
+MODULE PROCEDURE matmul_r4_r4_
INTEGER(I4B) :: ii
-ans = a2(1) * a1(:, :, 1)
-DO ii = 2, SIZE(a2)
- ans = ans + a2(ii) * a1(:, :, ii)
+
+dim6 = SIZE(a2, 4)
+
+DO ii = 1, dim6
+ CALL Matmul_(a1=a1, a2=a2(:, :, :, ii), ans=ans(:, :, :, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4, dim5=dim5)
END DO
+END PROCEDURE matmul_r4_r4_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r3_r1
+INTEGER(I4B) :: nrow, ncol
+CALL Matmul_(a1=a1, a2=a2, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE matmul_r3_r1
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
+MODULE PROCEDURE matmul_r3_r1_
+INTEGER(I4B) :: ii, jj, kk, tsize
+
+nrow = SIZE(a1, 1)
+ncol = SIZE(a1, 2)
+tsize = MIN(SIZE(a2), SIZE(a1, 3))
+
+ans(1:nrow, 1:ncol) = 0.0_DFP
+
+DO kk = 1, tsize
+ DO jj = 1, ncol
+ DO ii = 1, nrow
+ ans(ii, jj) = ans(ii, jj) + a2(kk) * a1(ii, jj, kk)
+ END DO
+ END DO
+END DO
+END PROCEDURE matmul_r3_r1_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE matmul_r3_r2
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE matmul_r3_r2
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r3_r2_
INTEGER(I4B) :: ii
-DO ii = 1, SIZE(a2, 2)
- ans(:, :, ii) = MATMUL(a1, a2(:, ii))
+
+dim3 = SIZE(a2, 2)
+
+DO ii = 1, dim3
+ CALL Matmul_(a1=a1, a2=a2(:, ii), ans=ans(:, :, ii), nrow=dim1, ncol=dim2)
END DO
-END PROCEDURE matmul_r3_r2
+END PROCEDURE matmul_r3_r2_
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
MODULE PROCEDURE matmul_r3_r3
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4)
+END PROCEDURE matmul_r3_r3
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r3_r3_
INTEGER(I4B) :: ii
-DO ii = 1, SIZE(a2, 3)
- ans(:,:,:,ii) = matmul(a1, a2(:, :, ii))
+
+dim4 = SIZE(a2, 3)
+
+DO ii = 1, dim4
+ CALL Matmul_(a1=a1, a2=a2(:, :, ii), ans=ans(:, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3)
END DO
-END PROCEDURE matmul_r3_r3
+END PROCEDURE matmul_r3_r3_
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
MODULE PROCEDURE matmul_r3_r4
+INTEGER(I4B) :: dim1, dim2, dim3, dim4, dim5
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4, dim5=dim5)
+END PROCEDURE matmul_r3_r4
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r3_r4_
INTEGER(I4B) :: ii
-DO ii = 1, SIZE(a2, 4)
- ans(:,:,:,:,ii) = matmul(a1, a2(:, :, :,ii))
+
+dim5 = SIZE(a2, 4)
+
+DO ii = 1, dim5
+ CALL Matmul_(a1=a1, a2=a2(:, :, :, ii), ans=ans(:, :, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3, dim4=dim4)
END DO
-END PROCEDURE matmul_r3_r4
+END PROCEDURE matmul_r3_r4_
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
MODULE PROCEDURE matmul_r2_r3
+INTEGER(I4B) :: dim1, dim2, dim3
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3)
+END PROCEDURE matmul_r2_r3
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r2_r3_
INTEGER(I4B) :: ii
-DO ii = 1, SIZE(a2, 3)
- ans(:, :, ii) = MATMUL(a1, a2(:, :, ii))
+
+dim1 = SIZE(a1, 1)
+dim2 = SIZE(a2, 2)
+dim3 = SIZE(a2, 3)
+
+DO ii = 1, dim3
+ ans(1:dim1, 1:dim2, ii) = MATMUL(a1, a2(:, :, ii))
END DO
-END PROCEDURE matmul_r2_r3
+END PROCEDURE matmul_r2_r3_
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
MODULE PROCEDURE matmul_r2_r4
+INTEGER(I4B) :: dim1, dim2, dim3, dim4
+CALL Matmul_(a1=a1, a2=a2, ans=ans, dim1=dim1, dim2=dim2, dim3=dim3, &
+ dim4=dim4)
+END PROCEDURE matmul_r2_r4
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r2_r4_
INTEGER(I4B) :: ii
-DO ii = 1, SIZE(a2, 4)
- ans(:, :, :, ii) = MATMUL(a1, a2(:, :, :, ii))
+
+dim4 = SIZE(a2, 4)
+DO ii = 1, dim4
+ CALL Matmul_(a1=a1, a2=a2(:, :, :, ii), ans=ans(:, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3)
END DO
-END PROCEDURE matmul_r2_r4
+END PROCEDURE matmul_r2_r4_
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
MODULE PROCEDURE matmul_r1_r1
- ans = DOT_PRODUCT(a1, a2)
+ans = DOT_PRODUCT(a1, a2)
END PROCEDURE matmul_r1_r1
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
+MODULE PROCEDURE matmul_r1_r1_
+ans = DOT_PRODUCT(a1, a2)
+END PROCEDURE matmul_r1_r1_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE matmul_r1_r3
-INTEGER(I4B) :: ii
-ans = a1(1) * a2(1, :, :)
-DO ii = 2, SIZE(a1)
- ans = ans + a1(ii) * a2(ii, :, :)
-END DO
+INTEGER(I4B) :: nrow, ncol
+CALL Matmul_(a1=a1, a2=a2, ans=ans, nrow=nrow, ncol=ncol)
END PROCEDURE matmul_r1_r3
!----------------------------------------------------------------------------
! MATMUL
!----------------------------------------------------------------------------
+MODULE PROCEDURE matmul_r1_r3_
+INTEGER(I4B) :: ii, jj, kk, tsize
+
+nrow = SIZE(a2, 2)
+ncol = SIZE(a2, 3)
+tsize = SIZE(a1)
+
+ans(1:nrow, 1:ncol) = 0.0_DFP
+
+DO kk = 1, ncol
+ DO jj = 1, nrow
+ DO ii = 1, tsize
+ ans(jj, kk) = ans(jj, kk) + a1(ii) * a2(ii, jj, kk)
+ END DO
+ END DO
+END DO
+END PROCEDURE matmul_r1_r3_
+
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE matmul_r1_r4
INTEGER(I4B) :: ii
ans = a1(1) * a2(1, :, :, :)
@@ -170,4 +343,30 @@
END DO
END PROCEDURE matmul_r1_r4
+!----------------------------------------------------------------------------
+! MATMUL
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE matmul_r1_r4_
+INTEGER(I4B) :: ii, jj, kk, ll, tsize
+
+dim1 = SIZE(a2, 2)
+dim2 = SIZE(a2, 3)
+dim3 = SIZE(a2, 4)
+tsize = SIZE(a1)
+
+ans(1:dim1, 1:dim2, 1:dim3) = 0.0_DFP
+
+DO ll = 1, dim3
+ DO kk = 1, dim2
+ DO jj = 1, dim1
+ DO ii = 1, tsize
+ ans(jj, kk, ll) = ans(jj, kk, ll) + a1(ii) * a2(ii, jj, kk, ll)
+ END DO
+ END DO
+ END DO
+END DO
+
+END PROCEDURE matmul_r1_r4_
+
END SUBMODULE Methods
diff --git a/src/submodules/Utility/src/ProductUtility@Methods.F90 b/src/submodules/Utility/src/ProductUtility@Methods.F90
index e68c7588c..5c332dd4e 100644
--- a/src/submodules/Utility/src/ProductUtility@Methods.F90
+++ b/src/submodules/Utility/src/ProductUtility@Methods.F90
@@ -17,13 +17,78 @@
!> 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 OTimesTilda3
+INTEGER(I4B) :: sa(2), sb(2)
+INTEGER(I4B) :: ii, jj, pp, qq
+
+sa(1) = SIZE(a)
+sa(2) = SIZE(b)
+sb(1) = SIZE(c)
+sb(2) = SIZE(d)
+
+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) * b(jj) * c(pp) * d(qq)
+END DO
+
+END PROCEDURE OTimesTilda3
+
+!----------------------------------------------------------------------------
+! 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 +113,598 @@
!
!----------------------------------------------------------------------------
-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
+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
+DO ii = 1, SIZE(b, 2)
+ ans(:, :, ii) = OuterProd(a, b(:, ii))
+END DO
+END PROCEDURE OuterProd_r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3
+MODULE PROCEDURE OuterProd_r1r2_
INTEGER(I4B) :: ii
-do ii = 1, size(b, 3)
- ans(:, :, :, ii) = outerprod(a, b(:, :, ii))
-end do
-END PROCEDURE outerprod_r1r3
+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_r1r4
+MODULE PROCEDURE OuterProd_r1r3
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, 3)
+ ans(:, :, :, ii) = OuterProd(a, b(:, :, ii))
+END DO
+END PROCEDURE OuterProd_r1r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r5
+MODULE PROCEDURE OuterProd_r1r4
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, 4)
+ ans(:, :, :, :, ii) = OuterProd(a, b(:, :, :, ii))
+END DO
+END PROCEDURE OuterProd_r1r4
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+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
!--------------------------------------------------------------------
!
!--------------------------------------------------------------------
-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_r2r1_
+INTEGER(I4B) :: ii
+dim1 = SIZE(a, 1)
+dim2 = SIZE(a, 2)
+dim3 = SIZE(b)
+
+DO ii = 1, dim3
+ ans(1:dim1, 1:dim2, ii) = anscoeff * ans(1:dim1, 1:dim2, ii) + &
+ scale * a(1:dim1, 1:dim2) * b(ii)
+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
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE OuterProd_r2r2_
+INTEGER(I4B) :: ii
+
+dim4 = SIZE(b, 2)
+
+DO ii = 1, dim4
+ CALL OuterProd_( &
+ a=a, b=b(:, ii), ans=ans(:, :, :, ii), anscoeff=anscoeff, &
+ scale=scale, dim1=dim1, dim2=dim2, dim3=dim3)
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
+! ans(i, j, k) = anscoeff * ans + scale * (a(i) * b(j)) * c(k))
+MODULE PROCEDURE OuterProd_r1r1r1_
+REAL(DFP) :: scale0
+INTEGER(I4B) :: kk
+
+dim1 = SIZE(a)
+dim2 = SIZE(b)
+dim3 = SIZE(c)
+
+DO kk = 1, dim3
+ scale0 = scale * c(kk)
+ CALL OuterProd_(a=a, b=b, ans=ans(:, :, kk), nrow=dim1, ncol=dim2, &
+ anscoeff=anscoeff, scale=scale0)
+END DO
+END PROCEDURE OuterProd_r1r1r1_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r3
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r1r3
+MODULE PROCEDURE OuterProd_r1r1r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r1r4
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r1r4
+MODULE PROCEDURE OuterProd_r1r1r2_
+INTEGER(I4B) :: ii
+
+dim4 = SIZE(c, 2)
+
+DO ii = 1, dim4
+ CALL OuterProd_(a=a, b=b, c=c(:, ii), ans=ans(:, :, :, ii), &
+ dim1=dim1, dim2=dim2, dim3=dim3, anscoeff=anscoeff, &
+ scale=scale)
+END DO
+END PROCEDURE OuterProd_r1r1r2_
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r2r1
+MODULE PROCEDURE OuterProd_r1r1r3
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r2r2
+MODULE PROCEDURE OuterProd_r1r1r4
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r1r4
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r2r3
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r2r3
+MODULE PROCEDURE OuterProd_r1r2r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r2r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r3r1
+MODULE PROCEDURE OuterProd_r1r2r2
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r2r2
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r3r2
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r3r2
+MODULE PROCEDURE OuterProd_r1r2r3
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r2r3
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r1r4r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r1r4r1
+MODULE PROCEDURE OuterProd_r1r3r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r1r3r1
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
-MODULE PROCEDURE outerprod_r2r1r1
-ans = outerprod(outerprod(a, b), c)
-END PROCEDURE outerprod_r2r1r1
+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_r2r1r1
+ans = OuterProd(OuterProd(a, b), c)
+END PROCEDURE OuterProd_r2r1r1
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+! ans = OuterProd(OuterProd(a, b), c)
+MODULE PROCEDURE OuterProd_r2r1r1_
+REAL(DFP) :: scale0
+INTEGER(I4B) :: kk
+
+dim1 = SIZE(a, 1)
+dim2 = SIZE(a, 2)
+dim3 = SIZE(b)
+dim4 = SIZE(c)
+
+DO kk = 1, dim4
+ scale0 = scale * c(kk)
+ CALL OuterProd_(a=a, b=b, ans=ans(:, :, :, kk), dim1=dim1, dim2=dim2, &
+ dim3=dim3, anscoeff=anscoeff, scale=scale0)
+END DO
+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..857e28cd8
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate2.F90
@@ -0,0 +1,57 @@
+LOGICAL :: isalloc, abool(3), ex, acase
+INTEGER(I4B) :: s(2), ii, jj, fac
+
+isalloc = ALLOCATED(mat)
+
+! If not allocated, then allocate and return
+IF (.NOT. isalloc) THEN
+ ALLOCATE (mat(row, col))
+ DO CONCURRENT(ii=1:row, jj=1:col)
+ mat(ii, jj) = ZEROVALUE
+ END DO
+ RETURN
+END IF
+
+ex = .FALSE.
+IF (PRESENT(isExpand)) ex = isExpand
+
+! If allocated and isExpand is false, the deallocat and allocate
+acase = .NOT. ex
+IF (acase) THEN
+ s = SHAPE(mat)
+
+ abool(1) = s(1) .NE. row .OR. s(2) .NE. col
+
+ IF (abool(1)) 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
+
+! If allocated and isExpand is true
+fac = 1
+IF (PRESENT(expandFactor)) fac = expandFactor
+
+s = SHAPE(mat)
+
+abool(1) = s(1) .LT. row
+abool(2) = s(2) .LT. col
+
+IF (abool(1)) s(1) = row * fac
+IF (abool(2)) s(2) = col * fac
+
+IF (ANY(abool)) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(s(1), s(2)))
+END IF
+
+DO CONCURRENT(ii=1:row, jj=1:col)
+ mat(ii, jj) = ZEROVALUE
+END DO
+
diff --git a/src/submodules/Utility/src/Reallocate/reallocate3.F90 b/src/submodules/Utility/src/Reallocate/reallocate3.F90
new file mode 100644
index 000000000..7521165d0
--- /dev/null
+++ b/src/submodules/Utility/src/Reallocate/reallocate3.F90
@@ -0,0 +1,60 @@
+LOGICAL :: isalloc, abool(3), ex, acase
+INTEGER(I4B) :: s(3), ii, jj, kk, fac
+
+isalloc = ALLOCATED(mat)
+
+! If not allocated, then allocate and return
+IF (.NOT. isalloc) THEN
+ ALLOCATE (mat(i1, i2, i3))
+ DO CONCURRENT(ii=1:i1, jj=1:i2, kk=1:i3)
+ mat(ii, jj, kk) = ZEROVALUE
+ END DO
+ RETURN
+END IF
+
+ex = .FALSE.
+IF (PRESENT(isExpand)) ex = isExpand
+
+! If allocated and isExpand is false, the deallocat and allocate
+acase = .NOT. ex
+IF (acase) THEN
+ s = SHAPE(mat)
+
+ abool(1) = s(1) .NE. i1 .OR. s(2) .NE. i2 .OR. s(3) .NE. i3
+
+ IF (abool(1)) THEN
+ DEALLOCATE (mat)
+ 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
+
+ RETURN
+END IF
+
+! If allocated and isExpand is true
+fac = 1
+IF (PRESENT(expandFactor)) fac = expandFactor
+
+s = SHAPE(mat)
+
+! abool = (s(1) .LT. i1) .OR. s(2) .NE. i2 .OR. s(3) .NE. i3
+abool(1) = s(1) .LT. i1
+abool(2) = s(2) .LT. i2
+abool(3) = s(3) .LT. i3
+
+IF (abool(1)) s(1) = i1 * fac
+IF (abool(2)) s(2) = i2 * fac
+IF (abool(3)) s(3) = i3 * fac
+
+IF (ANY(abool)) THEN
+ DEALLOCATE (mat)
+ ALLOCATE (mat(s(1), s(2), s(3)))
+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/Reverse/ReverseMatrix.F90 b/src/submodules/Utility/src/Reverse/ReverseMatrix.F90
new file mode 100644
index 000000000..aae4c629b
--- /dev/null
+++ b/src/submodules/Utility/src/Reverse/ReverseMatrix.F90
@@ -0,0 +1,51 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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
+
+INTEGER(I4B) :: tsize, halfSize, indx, indx1, indx2, ii
+
+SELECT CASE (dim)
+CASE (1)
+ ! dim = 1
+ tsize = r2 - r1 + 1
+ halfSize = tsize / 2
+
+ DO ii = c1, c2
+ DO indx = 1, halfSize
+ indx1 = r1 + indx - 1
+ indx2 = r2 - indx + 1
+ temp = ans(indx2, ii)
+ ans(indx2, ii) = ans(indx1, ii)
+ ans(indx1, ii) = temp
+ END DO
+ END DO
+
+CASE (2)
+ ! dim = 2
+ tsize = c2 - c1 + 1
+ halfSize = tsize / 2
+
+ DO indx = 1, halfSize
+ indx1 = c1 + indx - 1
+ indx2 = c2 - indx + 1
+ DO ii = r1, r2
+ temp = ans(ii, indx2)
+ ans(ii, indx2) = ans(ii, indx1)
+ ans(ii, indx1) = temp
+ END DO
+ END DO
+END SELECT
+
diff --git a/src/submodules/Utility/src/Reverse/ReverseVector.F90 b/src/submodules/Utility/src/Reverse/ReverseVector.F90
new file mode 100644
index 000000000..2d9be812f
--- /dev/null
+++ b/src/submodules/Utility/src/Reverse/ReverseVector.F90
@@ -0,0 +1,30 @@
+! This program is a part of EASIFEM library
+! Expandable And Scalable Infrastructure for Finite Element Methods
+! htttps://www.easifem.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
+
+! INTEGER(INT8) :: temp
+INTEGER(I4B) :: ii, jj, tsize, halfSize, indx
+
+tsize = n2 - n1 + 1
+halfSize = tsize / 2
+
+DO indx = 1, halfSize
+ ii = n1 + indx - 1
+ jj = n2 - indx + 1
+ temp = ans(jj)
+ ans(jj) = ans(ii)
+ ans(ii) = temp
+END DO
diff --git a/src/submodules/Utility/src/ReverseUtility@Methods.F90 b/src/submodules/Utility/src/ReverseUtility@Methods.F90
new file mode 100644
index 000000000..4cafa9d01
--- /dev/null
+++ b/src/submodules/Utility/src/ReverseUtility@Methods.F90
@@ -0,0 +1,196 @@
+! 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(ReverseUtility) Methods
+IMPLICIT NONE
+CONTAINS
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int8_R1
+INTEGER(INT8) :: temp
+#include "./Reverse/ReverseVector.F90"
+END PROCEDURE Reverse_Int8_R1
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int16_R1
+INTEGER(INT16) :: temp
+#include "./Reverse/ReverseVector.F90"
+END PROCEDURE Reverse_Int16_R1
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int32_R1
+INTEGER(INT32) :: temp
+#include "./Reverse/ReverseVector.F90"
+END PROCEDURE Reverse_Int32_R1
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int64_R1
+INTEGER(INT64) :: temp
+#include "./Reverse/ReverseVector.F90"
+END PROCEDURE Reverse_Int64_R1
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Real32_R1
+REAL(REAL32) :: temp
+#include "./Reverse/ReverseVector.F90"
+END PROCEDURE Reverse_Real32_R1
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Real64_R1
+REAL(REAL64) :: temp
+#include "./Reverse/ReverseVector.F90"
+END PROCEDURE Reverse_Real64_R1
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int8_R2
+INTEGER(INT8) :: temp
+#include "./Reverse/ReverseMatrix.F90"
+END PROCEDURE Reverse_Int8_R2
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int16_R2
+INTEGER(INT16) :: temp
+#include "./Reverse/ReverseMatrix.F90"
+END PROCEDURE Reverse_Int16_R2
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int32_R2
+INTEGER(INT32) :: temp
+#include "./Reverse/ReverseMatrix.F90"
+END PROCEDURE Reverse_Int32_R2
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Int64_R2
+INTEGER(INT64) :: temp
+#include "./Reverse/ReverseMatrix.F90"
+END PROCEDURE Reverse_Int64_R2
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Real32_R2
+REAL(REAL32) :: temp
+#include "./Reverse/ReverseMatrix.F90"
+END PROCEDURE Reverse_Real32_R2
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Real64_R2
+REAL(REAL64) :: temp
+#include "./Reverse/ReverseMatrix.F90"
+END PROCEDURE Reverse_Real64_R2
+
+!----------------------------------------------------------------------------
+! Reverse
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE Reverse_Real64_R3
+REAL(REAL64) :: temp
+INTEGER(I4B) :: tsize, halfSize, indx, indx1, indx2, ii, jj
+
+SELECT CASE (dim)
+CASE (1)
+ !! dim = 1
+ tsize = r2 - r1 + 1
+ halfSize = tsize / 2
+
+ DO jj = d1, d2
+ DO ii = c1, c2
+ DO indx = 1, halfSize
+ indx1 = r1 + indx - 1
+ indx2 = r2 - indx + 1
+ temp = ans(indx2, ii, jj)
+ ans(indx2, ii, jj) = ans(indx1, ii, jj)
+ ans(indx1, ii, jj) = temp
+ END DO
+ END DO
+ END DO
+
+CASE (2)
+ !! dim = 2
+ tsize = c2 - c1 + 1
+ halfSize = tsize / 2
+
+ DO jj = d1, d2
+ DO indx = 1, halfSize
+ indx1 = c1 + indx - 1
+ indx2 = c2 - indx + 1
+ DO ii = r1, r2
+ temp = ans(ii, indx2, jj)
+ ans(ii, indx2, jj) = ans(ii, indx1, jj)
+ ans(ii, indx1, jj) = temp
+ END DO
+ END DO
+ END DO
+
+CASE (3)
+ !! dim = 3
+ tsize = d2 - d1 + 1
+ halfSize = tsize / 2
+
+ DO indx = 1, halfSize
+ indx1 = d1 + indx - 1
+ indx2 = d2 - indx + 1
+ DO jj = c1, c2
+ DO ii = r1, r2
+ temp = ans(ii, jj, indx2)
+ ans(ii, jj, indx2) = ans(ii, jj, indx1)
+ ans(ii, jj, indx1) = temp
+ END DO
+ END DO
+ END DO
+END SELECT
+END PROCEDURE Reverse_Real64_R3
+
+!----------------------------------------------------------------------------
+!
+!----------------------------------------------------------------------------
+
+END SUBMODULE Methods
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
!----------------------------------------------------------------------------
diff --git a/src/submodules/Utility/src/SwapUtility@Methods.F90 b/src/submodules/Utility/src/SwapUtility@Methods.F90
index a078cd38d..f1641d7cd 100644
--- a/src/submodules/Utility/src/SwapUtility@Methods.F90
+++ b/src/submodules/Utility/src/SwapUtility@Methods.F90
@@ -20,7 +20,7 @@
! summary: This submodule contains method for swaping
SUBMODULE(SwapUtility) Methods
-USE BaseMethod
+USE ReallocateUtility, ONLY: Reallocate
IMPLICIT NONE
CONTAINS
@@ -101,11 +101,13 @@
a = b
b = dum
END PROCEDURE swap_r32v
+#endif
!----------------------------------------------------------------------------
! SWAP
!----------------------------------------------------------------------------
+#ifndef USE_BLAS95
MODULE PROCEDURE swap_r64v
REAL(REAL64), DIMENSION(SIZE(a)) :: dum
dum = a
@@ -119,10 +121,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int8v
-INTEGER(INT8), DIMENSION(SIZE(a)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT8) :: dum
+INTEGER(I4B) :: ii, n
+
+n = SIZE(a)
+
+DO ii = 1, n
+ dum = a(ii)
+ a(ii) = b(ii)
+ b(ii) = dum
+END DO
END PROCEDURE swap_Int8v
!----------------------------------------------------------------------------
@@ -130,10 +138,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int16v
-INTEGER(INT16), DIMENSION(SIZE(a)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT16) :: dum
+INTEGER(I4B) :: ii, n
+
+n = SIZE(a)
+
+DO ii = 1, n
+ dum = a(ii)
+ a(ii) = b(ii)
+ b(ii) = dum
+END DO
END PROCEDURE swap_Int16v
!----------------------------------------------------------------------------
@@ -141,10 +155,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int32v
-INTEGER(INT32), DIMENSION(SIZE(a)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT32) :: dum
+INTEGER(I4B) :: ii, n
+
+n = SIZE(a)
+
+DO ii = 1, n
+ dum = a(ii)
+ a(ii) = b(ii)
+ b(ii) = dum
+END DO
END PROCEDURE swap_Int32v
!----------------------------------------------------------------------------
@@ -152,10 +172,16 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int64v
-INTEGER(INT64), DIMENSION(SIZE(a)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT64) :: dum
+INTEGER(I4B) :: ii, n
+
+n = SIZE(a)
+
+DO ii = 1, n
+ dum = a(ii)
+ a(ii) = b(ii)
+ b(ii) = dum
+END DO
END PROCEDURE swap_Int64v
!----------------------------------------------------------------------------
@@ -164,10 +190,16 @@
#ifdef USE_Int128
MODULE PROCEDURE swap_Int128v
-INTEGER(Int128), DIMENSION(SIZE(a)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(Int128) :: dum
+INTEGER(I4B) :: ii, n
+
+n = SIZE(a)
+
+DO ii = 1, n
+ dum = a(ii)
+ a(ii) = b(ii)
+ b(ii) = dum
+END DO
END PROCEDURE swap_Int128v
#endif
@@ -188,10 +220,16 @@
#ifndef USE_BLAS95
MODULE PROCEDURE swap_cv
-COMPLEX(DFPC), DIMENSION(SIZE(a)) :: dum
-dum = a
-a = b
-b = dum
+COMPLEX(DFPC) :: dum
+INTEGER(I4B) :: ii, n
+
+n = SIZE(a)
+
+DO ii = 1, n
+ dum = a(ii)
+ a(ii) = b(ii)
+ b(ii) = dum
+END DO
END PROCEDURE swap_cv
#endif
@@ -200,10 +238,20 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_cm
-COMPLEX(DFPC), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+COMPLEX(DFPC) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
+
END PROCEDURE swap_cm
!----------------------------------------------------------------------------
@@ -211,10 +259,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_r32m
-REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+REAL(REAL32) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_r32m
!----------------------------------------------------------------------------
@@ -222,10 +279,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_r64m
-REAL(REAL32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+REAL(REAL64) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_r64m
!----------------------------------------------------------------------------
@@ -233,10 +299,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int8m
-INTEGER(INT8), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT8) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_Int8m
!----------------------------------------------------------------------------
@@ -244,10 +319,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int16m
-INTEGER(INT16), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT16) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_Int16m
!----------------------------------------------------------------------------
@@ -255,10 +339,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int32m
-INTEGER(INT32), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT32) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_Int32m
!----------------------------------------------------------------------------
@@ -266,10 +359,19 @@
!----------------------------------------------------------------------------
MODULE PROCEDURE swap_Int64m
-INTEGER(INT64), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT64) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_Int64m
!----------------------------------------------------------------------------
@@ -278,10 +380,19 @@
#ifdef USE_Int128
MODULE PROCEDURE swap_Int128m
-INTEGER(Int128), DIMENSION(SIZE(a, 1), SIZE(a, 2)) :: dum
-dum = a
-a = b
-b = dum
+INTEGER(INT128) :: dum
+INTEGER(I4B) :: ii, jj, nrow, ncol
+
+nrow = SIZE(a, 1)
+ncol = SIZE(a, 2)
+
+DO jj = 1, ncol
+ DO ii = 1, nrow
+ dum = a(ii, jj)
+ a(ii, jj) = b(ii, jj)
+ b(ii, jj) = dum
+ END DO
+END DO
END PROCEDURE swap_Int128m
#endif
@@ -591,6 +702,38 @@
! SWAP
!----------------------------------------------------------------------------
+MODULE PROCEDURE swap_index_1
+INTEGER(I4B) :: ij(2), s(2), i, j
+!! main
+s = SHAPE(b)
+DO j = 1, s(2)
+ DO i = 1, s(1)
+ ij(1) = i; ij(2) = j
+ a(ij(i1), ij(i2)) = b(i, j)
+ END DO
+END DO
+END PROCEDURE swap_index_1
+
+!----------------------------------------------------------------------------
+! SWAP
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE swap_index_2
+INTEGER(I4B) :: ij(2), s(2), i, j
+!! main
+s = SHAPE(b)
+DO j = 1, s(2)
+ DO i = 1, s(1)
+ ij(1) = i; ij(2) = j
+ a(ij(i1), ij(i2)) = b(i, j)
+ END DO
+END DO
+END PROCEDURE swap_index_2
+
+!----------------------------------------------------------------------------
+! SWAP
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE swap_index2
INTEGER(I4B) :: IJ(2), s(2), i, j
!! main
@@ -664,6 +807,42 @@
! SWAP
!----------------------------------------------------------------------------
+MODULE PROCEDURE swap_index_3
+INTEGER(I4B) :: ijk(3), s(3), i, j, k
+!! main
+s = SHAPE(b)
+DO k = 1, s(3)
+ DO j = 1, s(2)
+ DO i = 1, s(1)
+ ijk = [i, j, k]
+ a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k)
+ END DO
+ END DO
+END DO
+END PROCEDURE swap_index_3
+
+!----------------------------------------------------------------------------
+! SWAP
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE swap_index_4
+INTEGER(I4B) :: ijk(3), s(3), i, j, k
+!! main
+s = SHAPE(b)
+DO k = 1, s(3)
+ DO j = 1, s(2)
+ DO i = 1, s(1)
+ ijk = [i, j, k]
+ a(ijk(i1), ijk(i2), ijk(i3)) = b(i, j, k)
+ END DO
+ END DO
+END DO
+END PROCEDURE swap_index_4
+
+!----------------------------------------------------------------------------
+! SWAP
+!----------------------------------------------------------------------------
+
MODULE PROCEDURE swap_index5
INTEGER(I4B) :: indx(4), s(4), i, j, k, l
!! main
@@ -702,6 +881,46 @@
END DO
END PROCEDURE swap_index6
+!----------------------------------------------------------------------------
+! SWAP
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE swap_index_5
+INTEGER(I4B) :: indx(4), s(4), i, j, k, l
+!! main
+s = SHAPE(b)
+DO l = 1, s(4)
+ DO k = 1, s(3)
+ DO j = 1, s(2)
+ DO i = 1, s(1)
+ indx = [i, j, k, l]
+ a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l)
+ END DO
+ END DO
+ END DO
+END DO
+END PROCEDURE swap_index_5
+
+!----------------------------------------------------------------------------
+! SWAP
+!----------------------------------------------------------------------------
+
+MODULE PROCEDURE swap_index_6
+INTEGER(I4B) :: indx(4), s(4), i, j, k, l
+!! main
+s = SHAPE(b)
+DO l = 1, s(4)
+ DO k = 1, s(3)
+ DO j = 1, s(2)
+ DO i = 1, s(1)
+ indx = [i, j, k, l]
+ a(indx(i1), indx(i2), indx(i3), indx(i4)) = b(i, j, k, l)
+ END DO
+ END DO
+ END DO
+END DO
+END PROCEDURE swap_index_6
+
!----------------------------------------------------------------------------
!
!----------------------------------------------------------------------------
diff --git a/src/submodules/include/errors.F90 b/src/submodules/include/errors.F90
new file mode 100644
index 000000000..97548e3d2
--- /dev/null
+++ b/src/submodules/include/errors.F90
@@ -0,0 +1,19 @@
+!----------------------------------------------------------------------------
+! AssertError1
+!----------------------------------------------------------------------------
+
+SUBROUTINE AssertError1(a, myName, modName, lineNo, msg)
+ USE GlobalData, ONLY: I4B, stderr
+ USE ErrorHandling, ONLY: Errormsg
+ LOGICAL, INTENT(IN) :: a
+ CHARACTER(*), INTENT(IN) :: myName, modName, msg
+ INTEGER(I4B), INTENT(IN) :: lineNo
+
+ IF (.NOT. a) THEN
+ CALL Errormsg(msg=msg, file=modName, routine=myName, &
+ line=lineNo, unitno=stderr)
+ STOP
+ END IF
+
+END SUBROUTINE AssertError1
+